line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package PDL::LinearAlgebra; |
2
|
1
|
|
|
1
|
|
154829
|
use PDL::Ops; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
10
|
|
3
|
1
|
|
|
1
|
|
198
|
use PDL::Core; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
11
|
|
4
|
1
|
|
|
1
|
|
414
|
use PDL::Basic qw/sequence/; |
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
8
|
|
5
|
1
|
|
|
1
|
|
106
|
use PDL::Primitive qw/which which_both/; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
8
|
|
6
|
1
|
|
|
1
|
|
155
|
use PDL::Ufunc qw/sumover/; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
8
|
|
7
|
1
|
|
|
1
|
|
117
|
use PDL::NiceSlice; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
11
|
|
8
|
1
|
|
|
1
|
|
221537
|
use PDL::Slices; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
10
|
|
9
|
1
|
|
|
1
|
|
956
|
use PDL::Complex; |
|
1
|
|
|
|
|
6528
|
|
|
1
|
|
|
|
|
9
|
|
10
|
1
|
|
|
1
|
|
1601
|
use PDL::LinearAlgebra::Real; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
use PDL::LinearAlgebra::Complex; |
12
|
|
|
|
|
|
|
use PDL::LinearAlgebra::Special qw//; |
13
|
|
|
|
|
|
|
use PDL::Exporter; |
14
|
|
|
|
|
|
|
no warnings 'uninitialized'; |
15
|
|
|
|
|
|
|
use constant{ |
16
|
|
|
|
|
|
|
NO => 0, |
17
|
|
|
|
|
|
|
WARN => 1, |
18
|
|
|
|
|
|
|
BARF => 2, |
19
|
|
|
|
|
|
|
}; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
use strict; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
our $VERSION = '0.12'; |
24
|
|
|
|
|
|
|
$VERSION = eval $VERSION; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
@PDL::LinearAlgebra::ISA = qw/PDL::Exporter/; |
27
|
|
|
|
|
|
|
@PDL::LinearAlgebra::EXPORT_OK = qw/t diag issym minv mtriinv msyminv mposinv mdet mposdet mrcond positivise |
28
|
|
|
|
|
|
|
mdsvd msvd mgsvd mlu mhessen mchol mqr mql mlq mrq meigen meigenx |
29
|
|
|
|
|
|
|
mgeigen mgeigenx msymeigen msymeigenx msymgeigen msymgeigenx |
30
|
|
|
|
|
|
|
msolve mtrisolve msymsolve mpossolve msolvex msymsolvex mpossolvex |
31
|
|
|
|
|
|
|
mrank mlls mllsy mllss mglm mlse tritosym mnorm mgschur mgschurx |
32
|
|
|
|
|
|
|
mcrossprod mcond morth mschur mschurx posinf neginf nan |
33
|
|
|
|
|
|
|
NO WARN BARF setlaerror getlaerorr laerror/; |
34
|
|
|
|
|
|
|
%PDL::LinearAlgebra::EXPORT_TAGS = (Func=>[@PDL::LinearAlgebra::EXPORT_OK]); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
my $_laerror = BARF; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
my $nan; |
39
|
|
|
|
|
|
|
BEGIN { $nan = 0/pdl(0) } |
40
|
|
|
|
|
|
|
sub nan() { $nan->copy }; |
41
|
|
|
|
|
|
|
my $posinf; |
42
|
|
|
|
|
|
|
BEGIN { $posinf = 1/pdl(0) } |
43
|
|
|
|
|
|
|
sub posinf() { $posinf->copy }; |
44
|
|
|
|
|
|
|
my $neginf; |
45
|
|
|
|
|
|
|
BEGIN { $neginf = -1/pdl(0) } |
46
|
|
|
|
|
|
|
sub neginf() { $neginf->copy }; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
{ |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
package # hide from CPAN indexer |
51
|
|
|
|
|
|
|
PDL::Complex; |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
use PDL::Types; |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
use vars qw($sep $sep2); |
56
|
|
|
|
|
|
|
our $floatformat = "%4.4g"; # Default print format for long numbers |
57
|
|
|
|
|
|
|
our $doubleformat = "%6.6g"; |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
*r2p = \&PDL::Complex::Cr2p; |
61
|
|
|
|
|
|
|
*p2r = \&PDL::Complex::Cp2r; |
62
|
|
|
|
|
|
|
*scale = \&PDL::Complex::Cscale; |
63
|
|
|
|
|
|
|
*conj = \&PDL::Complex::Cconj; |
64
|
|
|
|
|
|
|
*abs2 = \&PDL::Complex::Cabs2; |
65
|
|
|
|
|
|
|
*arg = \&PDL::Complex::Carg; |
66
|
|
|
|
|
|
|
*tan = \&PDL::Complex::Ctan; |
67
|
|
|
|
|
|
|
*proj = \&PDL::Complex::Cproj; |
68
|
|
|
|
|
|
|
*asin = \&PDL::Complex::Casin; |
69
|
|
|
|
|
|
|
*acos = \&PDL::Complex::Cacos; |
70
|
|
|
|
|
|
|
*atan = \&PDL::Complex::Catan; |
71
|
|
|
|
|
|
|
*sinh = \&PDL::Complex::Csinh; |
72
|
|
|
|
|
|
|
*cosh = \&PDL::Complex::Ccosh; |
73
|
|
|
|
|
|
|
*tanh = \&PDL::Complex::Ctanh; |
74
|
|
|
|
|
|
|
*asinh = \&PDL::Complex::Casinh; |
75
|
|
|
|
|
|
|
*acosh = \&PDL::Complex::Cacosh; |
76
|
|
|
|
|
|
|
*atanh = \&PDL::Complex::Catanh; |
77
|
|
|
|
|
|
|
*prodover = \&PDL::Complex::Cprodover; |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
sub ecplx { |
80
|
|
|
|
|
|
|
my ($re, $im) = @_; |
81
|
|
|
|
|
|
|
return $re if UNIVERSAL::isa($re,'PDL::Complex'); |
82
|
|
|
|
|
|
|
if (defined $im){ |
83
|
|
|
|
|
|
|
$re = pdl($re) unless (UNIVERSAL::isa($re,'PDL')); |
84
|
|
|
|
|
|
|
$im = pdl($im) unless (UNIVERSAL::isa($im,'PDL')); |
85
|
|
|
|
|
|
|
my $ret = PDL::new_from_specification('PDL::Complex', $re->type, 2, $re->dims); |
86
|
|
|
|
|
|
|
$ret->slice('(0),') .= $re; |
87
|
|
|
|
|
|
|
$ret->slice('(1),') .= $im; |
88
|
|
|
|
|
|
|
return $ret; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
croak "first dimsize must be 2" unless $re->dims > 0 && $re->dim(0) == 2; |
91
|
|
|
|
|
|
|
bless $_[0]->slice(''); |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
sub sumover { |
96
|
|
|
|
|
|
|
my $c = shift; |
97
|
|
|
|
|
|
|
return dims($c) > 1 ? PDL::Ufunc::sumover($c->xchg(0,1)) : $c; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
sub norm { |
103
|
|
|
|
|
|
|
my ($m, $real, $trans) = @_; |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
# If trans == true => transpose output matrice |
106
|
|
|
|
|
|
|
# If real == true => rotate (complex as a vector) |
107
|
|
|
|
|
|
|
# such that max abs will be real |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
#require PDL::LinearAlgebra::Complex; |
110
|
|
|
|
|
|
|
PDL::LinearAlgebra::Complex::cnrm2($m,1, my $ret = null); |
111
|
|
|
|
|
|
|
if ($real){ |
112
|
|
|
|
|
|
|
my ($index, $scale); |
113
|
|
|
|
|
|
|
$m = PDL::Complex::Cscale($m,1/$ret->dummy(0))->reshape(-1); |
114
|
|
|
|
|
|
|
$index = $m->Cabs->maximum_ind; |
115
|
|
|
|
|
|
|
$scale = $m->mv(0,-1)->index($index)->mv(-1,0); |
116
|
|
|
|
|
|
|
$scale= $scale->Cconj/$scale->Cabs; |
117
|
|
|
|
|
|
|
return $trans ? $m->xchg(1,2)*$scale->dummy(2) : $m*$scale->dummy(2)->xchg(1,2); |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
return $trans ? PDL::Complex::Cscale($m->xchg(1,2),1/$ret->dummy(0)->xchg(0,1))->reshape(-1) : |
120
|
|
|
|
|
|
|
PDL::Complex::Cscale($m,1/$ret->dummy(0))->reshape(-1); |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
######################################################################## |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
=encoding Latin-1 |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
=head1 NAME |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
PDL::LinearAlgebra - Linear Algebra utils for PDL |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
=head1 SYNOPSIS |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
use PDL::LinearAlgebra; |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
$a = random (100,100); |
138
|
|
|
|
|
|
|
($U, $s, $V) = mdsvd($a); |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
=head1 DESCRIPTION |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
This module provides a convenient interface to L |
143
|
|
|
|
|
|
|
and L. Its primary purpose is educational. |
144
|
|
|
|
|
|
|
You have to know that routines defined here are not optimized, particularly in term of memory. Since |
145
|
|
|
|
|
|
|
Blas and Lapack use a column major ordering scheme some routines here need to transpose matrices before |
146
|
|
|
|
|
|
|
calling fortran routines and transpose back (see the documentation of each routine). If you need |
147
|
|
|
|
|
|
|
optimized code use directly L and |
148
|
|
|
|
|
|
|
L. It's planned to "port" this module to PDL::Matrix such |
149
|
|
|
|
|
|
|
that transpositions will not be necessary, the major problem is that two new modules need to be created PDL::Matrix::Real |
150
|
|
|
|
|
|
|
and PDL::Matrix::Complex. |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
=cut |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
=head1 FUNCTIONS |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
=head2 setlaerror |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
=for ref |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
Sets action type when an error is encountered, returns previous type. Available values are NO, WARN and BARF (predefined constants). |
163
|
|
|
|
|
|
|
If, for example, in computation of the inverse, singularity is detected, |
164
|
|
|
|
|
|
|
the routine can silently return values from computation (see manuals), |
165
|
|
|
|
|
|
|
warn about singularity or barf. BARF is the default value. |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
=for example |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
# h : x -> g(f(x)) |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
$a = sequence(5,5); |
172
|
|
|
|
|
|
|
$err = setlaerror(NO); |
173
|
|
|
|
|
|
|
($b, $info)= f($a); |
174
|
|
|
|
|
|
|
setlaerror($err); |
175
|
|
|
|
|
|
|
$info ? barf "can't compute h" : return g($b); |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=cut |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub setlaerror($){ |
181
|
|
|
|
|
|
|
my $err = $_laerror; |
182
|
|
|
|
|
|
|
$_laerror = shift; |
183
|
|
|
|
|
|
|
$err; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
=head2 getlaerror |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
=for ref |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
Gets action type when an error is encountered. |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
0 => NO, |
193
|
|
|
|
|
|
|
1 => WARN, |
194
|
|
|
|
|
|
|
2 => BARF |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
=cut |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
sub getlaerror{ |
199
|
|
|
|
|
|
|
$_laerror; |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
sub laerror{ |
203
|
|
|
|
|
|
|
return unless $_laerror; |
204
|
|
|
|
|
|
|
if ($_laerror < 2){ |
205
|
|
|
|
|
|
|
warn "$_[0]\n"; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
else{ |
208
|
|
|
|
|
|
|
barf "$_[0]\n"; |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=head2 t |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
=for usage |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
PDL = t(PDL, SCALAR(conj)) |
217
|
|
|
|
|
|
|
conj : Conjugate Transpose = 1 | Transpose = 0, default = 1; |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
=for ref |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
Convenient function for transposing real or complex 2D array(s). |
222
|
|
|
|
|
|
|
For PDL::Complex, if conj is true returns conjugate transposed array(s) and doesn't support dataflow. |
223
|
|
|
|
|
|
|
Supports threading. |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
=cut |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
sub t{ |
228
|
|
|
|
|
|
|
my $m = shift; |
229
|
|
|
|
|
|
|
$m->t(@_); |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
sub PDL::t { |
233
|
|
|
|
|
|
|
$_[0]->xchg(0,1); |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
sub PDL::Complex::t { |
236
|
|
|
|
|
|
|
my ($m, $conj) = @_; |
237
|
|
|
|
|
|
|
$conj = 1 unless defined($conj); |
238
|
|
|
|
|
|
|
$conj ? PDL::Complex::Cconj($m->xchg(1,2)) : $m->xchg(1,2); |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
=head2 issym |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
=for usage |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
PDL = issym(PDL, SCALAR|PDL(tol),SCALAR(hermitian)) |
246
|
|
|
|
|
|
|
tol : tolerance value, default: 1e-8 for double else 1e-5 |
247
|
|
|
|
|
|
|
hermitian : Hermitian = 1 | Symmetric = 0, default = 1; |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
=for ref |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
Checks symmetricity/Hermitianicity of matrix. |
252
|
|
|
|
|
|
|
Supports threading. |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
=cut |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
sub issym{ |
257
|
|
|
|
|
|
|
my $m = shift; |
258
|
|
|
|
|
|
|
$m->issym(@_); |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
sub PDL::issym { |
262
|
|
|
|
|
|
|
my ($m, $tol) = @_; |
263
|
|
|
|
|
|
|
my @dims = $m->dims; |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
barf("issym: Require square array(s)") |
266
|
|
|
|
|
|
|
if( $dims[0] != $dims[1] ); |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
$tol = defined($tol) ? $tol : ($m->type == double) ? 1e-8 : 1e-5; |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
my ($min,$max) = PDL::Ufunc::minmaximum($m - $m->xchg(0,1)); |
271
|
|
|
|
|
|
|
$min = $min->minimum; |
272
|
|
|
|
|
|
|
$max = $max->maximum; |
273
|
|
|
|
|
|
|
return (((abs($max) > $tol) + (abs($min) > $tol)) == 0); |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
sub PDL::Complex::issym { |
277
|
|
|
|
|
|
|
my ($m, $tol, $conj) = @_; |
278
|
|
|
|
|
|
|
my @dims = $m->dims; |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
barf("issym: Require square array(s)") |
281
|
|
|
|
|
|
|
if( $dims[1] != $dims[2] ); |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
$conj = 1 unless defined($conj); |
284
|
|
|
|
|
|
|
$tol = defined($tol) ? $tol : ($m->type == double) ? 1e-8 : 1e-5; |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
my ($min, $max, $mini, $maxi); |
287
|
|
|
|
|
|
|
if ($conj){ |
288
|
|
|
|
|
|
|
($min,$max) = PDL::Ufunc::minmaximum(PDL::clump($m - $m->t(1),2)); |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
else{ |
291
|
|
|
|
|
|
|
($min,$max) = PDL::Ufunc::minmaximum(PDL::clump($m - $m->xchg(1,2),2)); |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
$min->minimum($mini = null); |
294
|
|
|
|
|
|
|
$max->maximum($maxi = null); |
295
|
|
|
|
|
|
|
return (((abs($maxi) > $tol) + (abs($mini) > $tol)) == 0); |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
=head2 diag |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
=for ref |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
Returns i-th diagonal if matrix in entry or matrix with i-th diagonal |
305
|
|
|
|
|
|
|
with entry. I-th diagonal returned flows data back&forth. |
306
|
|
|
|
|
|
|
Can be used as lvalue subs if your perl supports it. |
307
|
|
|
|
|
|
|
Supports threading. |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
=for usage |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
PDL = diag(PDL, SCALAR(i), SCALAR(vector))) |
312
|
|
|
|
|
|
|
i : i-th diagonal, default = 0 |
313
|
|
|
|
|
|
|
vector : create diagonal matrices by threading over row vectors, default = 0 |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
=for example |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
my $a = random(5,5); |
319
|
|
|
|
|
|
|
my $diag = diag($a,2); |
320
|
|
|
|
|
|
|
# If your perl support lvaluable subroutines. |
321
|
|
|
|
|
|
|
$a->diag(-2) .= pdl(1,2,3); |
322
|
|
|
|
|
|
|
# Construct a (5,5,5) PDL (5 matrices) with |
323
|
|
|
|
|
|
|
# diagonals from row vectors of $a |
324
|
|
|
|
|
|
|
$a->diag(0,1) |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
=cut |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
sub diag{ |
329
|
|
|
|
|
|
|
my $m = shift; |
330
|
|
|
|
|
|
|
$m->diag(@_); |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
sub PDL::diag{ |
333
|
|
|
|
|
|
|
my ($a,$i, $vec) = @_; |
334
|
|
|
|
|
|
|
my ($diag, $dim, @dims, $z); |
335
|
|
|
|
|
|
|
@dims = $a->dims; |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
$diag = ($i < 0) ? -$i : $i ; |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
if (@dims == 1 || $vec){ |
340
|
|
|
|
|
|
|
$dim = $dims[0]; |
341
|
|
|
|
|
|
|
my $zz = $dim + $diag; |
342
|
|
|
|
|
|
|
$z= PDL::zeroes('PDL',$a->type,$zz, $zz,@dims[1..$#dims]); |
343
|
|
|
|
|
|
|
if ($i){ |
344
|
|
|
|
|
|
|
($i < 0) ? $z(:($dim-1),$diag:)->diagonal(0,1) .= $a : $z($diag:,:($dim-1))->diagonal(0,1).=$a; |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
else{ $z->diagonal(0,1) .= $a; } |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
elsif($i < 0){ |
349
|
|
|
|
|
|
|
$z = $a(:-$diag-1 , $diag:)->diagonal(0,1); |
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
elsif($i){ |
352
|
|
|
|
|
|
|
$z = $a($diag:, :-$diag-1)->diagonal(0,1); |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
else{$z = $a->diagonal(0,1);} |
355
|
|
|
|
|
|
|
$z; |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
sub PDL::Complex::diag{ |
359
|
|
|
|
|
|
|
my ($a,$i, $vec) = @_; |
360
|
|
|
|
|
|
|
my ($diag, $dim, @dims, $z); |
361
|
|
|
|
|
|
|
@dims = $a->dims; |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
$diag = ($i < 0) ? -$i : $i ; |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
if (@dims == 2 || $vec){ |
367
|
|
|
|
|
|
|
$dim = $dims[1]; |
368
|
|
|
|
|
|
|
my $zz = $dim + $diag; |
369
|
|
|
|
|
|
|
$z= PDL::zeroes('PDL::Complex',$a->type, 2, $zz, $zz,@dims[2..$#dims]); |
370
|
|
|
|
|
|
|
if ($i){ |
371
|
|
|
|
|
|
|
($i < 0) ? $z(,:($dim-1),$diag:)->diagonal(1,2) .= $a : $z(,$diag:,:($dim-1))->diagonal(1,2).=$a; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
else{ $z->diagonal(1,2) .= $a; } |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
elsif($i < 0){ |
376
|
|
|
|
|
|
|
$z = $a(,:-$diag-1 , $diag:)->diagonal(1,2); |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
elsif($i){ |
379
|
|
|
|
|
|
|
$z = $a(,$diag:, :-$diag-1 )->diagonal(1,2); |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
else{ |
382
|
|
|
|
|
|
|
$z = $a->diagonal(1,2); |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
$z; |
385
|
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
if ($^V and $^V ge v5.6.0){ |
388
|
|
|
|
|
|
|
use attributes 'PDL', \&PDL::diag, 'lvalue'; |
389
|
|
|
|
|
|
|
use attributes 'PDL', \&PDL::Complex::diag, 'lvalue'; |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
=head2 tritosym |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
=for ref |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
Returns symmetric or Hermitian matrix from lower or upper triangular matrix. |
397
|
|
|
|
|
|
|
Supports inplace and threading. |
398
|
|
|
|
|
|
|
Uses L or L from Lapack. |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
=for usage |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
PDL = tritosym(PDL, SCALAR(uplo), SCALAR(conj)) |
403
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1, default = 0 |
404
|
|
|
|
|
|
|
conj : Hermitian = 1 | Symmetric = 0, default = 1; |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
=for example |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
# Assume $a is symmetric triangular |
409
|
|
|
|
|
|
|
my $a = random(10,10); |
410
|
|
|
|
|
|
|
my $b = tritosym($a); |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
=cut |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
sub tritosym{ |
415
|
|
|
|
|
|
|
my $m = shift; |
416
|
|
|
|
|
|
|
$m->tritosym(@_); |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
sub PDL::tritosym { |
420
|
|
|
|
|
|
|
my ($m, $upper) = @_; |
421
|
|
|
|
|
|
|
my @dims = $m->dims; |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
barf("tritosym: Require square array(s)") |
424
|
|
|
|
|
|
|
unless( $dims[0] == $dims[1] ); |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
my $b = $m->is_inplace ? $m : PDL::new_from_specification(ref($m),$m->type,@dims); |
427
|
|
|
|
|
|
|
$m->tricpy($upper, $b) unless $m->is_inplace(0); |
428
|
|
|
|
|
|
|
$m->tricpy($upper, $b->xchg(0,1)); |
429
|
|
|
|
|
|
|
$b; |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
sub PDL::Complex::tritosym { |
434
|
|
|
|
|
|
|
my ($m, $upper, $conj) = @_; |
435
|
|
|
|
|
|
|
my @dims = $m->dims; |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
barf("tritosym: Require square array(s)") |
438
|
|
|
|
|
|
|
if( $dims[1] != $dims[2] ); |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
my $b = $m->is_inplace ? $m : PDL::new_from_specification(ref($m),$m->type,@dims); |
441
|
|
|
|
|
|
|
$conj = 1 unless defined($conj); |
442
|
|
|
|
|
|
|
$conj ? PDL::Complex::Cconj($m)->ctricpy($upper, $b->xchg(1,2)) : |
443
|
|
|
|
|
|
|
$m->ctricpy($upper, $b->xchg(1,2)); |
444
|
|
|
|
|
|
|
# ... |
445
|
|
|
|
|
|
|
$m->ctricpy($upper, $b) unless (!$conj && $m->is_inplace(0)); |
446
|
|
|
|
|
|
|
$b((1),)->diagonal(0,1) .= 0 if $conj; |
447
|
|
|
|
|
|
|
$b; |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
=head2 positivise |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
=for ref |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
Returns entry pdl with changed sign by row so that average of positive sign > 0. |
457
|
|
|
|
|
|
|
In other words threads among dimension 1 and row = -row if sum(sign(row)) < 0. |
458
|
|
|
|
|
|
|
Works inplace. |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
=for example |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
my $a = random(10,10); |
463
|
|
|
|
|
|
|
$a -= 0.5; |
464
|
|
|
|
|
|
|
$a->xchg(0,1)->inplace->positivise; |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
=cut |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
*positivise = \&PDL::positivise; |
469
|
|
|
|
|
|
|
sub PDL::positivise{ |
470
|
|
|
|
|
|
|
my $m = shift; |
471
|
|
|
|
|
|
|
my $tmp; |
472
|
|
|
|
|
|
|
$m = $m->copy unless $m->is_inplace(0); |
473
|
|
|
|
|
|
|
$tmp = $m->dice('X', which(( $m->lt(0,0)->sumover > ($m->dim(0)/2))>0)); |
474
|
|
|
|
|
|
|
$tmp->inplace->mult(-1,0);# .= -$tmp; |
475
|
|
|
|
|
|
|
$m; |
476
|
|
|
|
|
|
|
} |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
=head2 mcrossprod |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
=for ref |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
Computes the cross-product of two matrix: A' x B. |
486
|
|
|
|
|
|
|
If only one matrix is given, takes B to be the same as A. |
487
|
|
|
|
|
|
|
Supports threading. |
488
|
|
|
|
|
|
|
Uses L or L. |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
=for usage |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
PDL = mcrossprod(PDL(A), (PDL(B)) |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
=for example |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
my $a = random(10,10); |
497
|
|
|
|
|
|
|
my $crossproduct = mcrossprod($a); |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
=cut |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
sub mcrossprod{ |
502
|
|
|
|
|
|
|
my $m = shift; |
503
|
|
|
|
|
|
|
$m->mcrossprod(@_); |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
sub PDL::mcrossprod { |
507
|
|
|
|
|
|
|
my($a, $b) = @_; |
508
|
|
|
|
|
|
|
my(@dims) = $a->dims; |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
barf("mcrossprod: Require 2D array(s)") |
511
|
|
|
|
|
|
|
unless( @dims >= 2 ); |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
$b = $a unless defined $b; |
514
|
|
|
|
|
|
|
$a->crossprod($b); |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
sub PDL::Complex::mcrossprod { |
518
|
|
|
|
|
|
|
my($a, $b) = @_; |
519
|
|
|
|
|
|
|
my(@dims) = $a->dims; |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
barf("mcrossprod: Require 2D array(s)") |
522
|
|
|
|
|
|
|
unless( @dims >= 3); |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
$b = $a unless defined $b; |
525
|
|
|
|
|
|
|
$a->ccrossprod($b); |
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
=head2 mrank |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
=for ref |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
Computes the rank of a matrix, using a singular value decomposition. |
534
|
|
|
|
|
|
|
from Lapack. |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
=for usage |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
SCALAR = mrank(PDL, SCALAR(TOL)) |
539
|
|
|
|
|
|
|
TOL: tolerance value, default : mnorm(dims(PDL),'inf') * mnorm(PDL) * EPS |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
=for example |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
my $a = random(10,10); |
544
|
|
|
|
|
|
|
my $b = mrank($a, 1e-5); |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
=cut |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
*mrank = \&PDL::mrank; |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
sub PDL::mrank { |
551
|
|
|
|
|
|
|
my($m, $tol) = @_; |
552
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
barf("mrank: Require a 2D matrix") |
555
|
|
|
|
|
|
|
unless( @dims == 2 or @dims == 3 ); |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
my ($sv, $info, $err); |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
$err = setlaerror(NO); |
560
|
|
|
|
|
|
|
# Sometimes mdsvd bugs for float (SGEBRD) |
561
|
|
|
|
|
|
|
# ($sv, $info) = $m->msvd(0, 0); |
562
|
|
|
|
|
|
|
($sv, $info) = $m->mdsvd(0); |
563
|
|
|
|
|
|
|
setlaerror($err); |
564
|
|
|
|
|
|
|
barf("mrank: SVD algorithm did not converge\n") if $info; |
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
unless (defined $tol){ |
567
|
|
|
|
|
|
|
$tol = ($dims[-1] > $dims[-2] ? $dims[-1] : $dims[-2]) * $sv((0)) * lamch(pdl($m->type,3)); |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
(which($sv > $tol))->dim(0); |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
=head2 mnorm |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
=for ref |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
Computes norm of real or complex matrix |
577
|
|
|
|
|
|
|
Supports threading. |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
=for usage |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
PDL(norm) = mnorm(PDL, SCALAR(ord)); |
582
|
|
|
|
|
|
|
ord : |
583
|
|
|
|
|
|
|
0|'inf' : Infinity norm |
584
|
|
|
|
|
|
|
1|'one' : One norm |
585
|
|
|
|
|
|
|
2|'two' : norm 2 (default) |
586
|
|
|
|
|
|
|
3|'fro' : frobenius norm |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
=for example |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
my $a = random(10,10); |
591
|
|
|
|
|
|
|
my $norm = mnorm($a); |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
=cut |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
sub mnorm { |
596
|
|
|
|
|
|
|
my $m =shift; |
597
|
|
|
|
|
|
|
$m->mnorm(@_); |
598
|
|
|
|
|
|
|
} |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
sub PDL::mnorm { |
602
|
|
|
|
|
|
|
my ($m, $ord) = @_; |
603
|
|
|
|
|
|
|
$ord = 2 unless (defined $ord); |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
if ($ord eq 'inf'){ |
606
|
|
|
|
|
|
|
$ord = 0; |
607
|
|
|
|
|
|
|
} |
608
|
|
|
|
|
|
|
elsif ($ord eq 'one'){ |
609
|
|
|
|
|
|
|
$ord = 1; |
610
|
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
elsif($ord eq 'two'){ |
612
|
|
|
|
|
|
|
$ord = 2; |
613
|
|
|
|
|
|
|
} |
614
|
|
|
|
|
|
|
elsif($ord eq 'fro'){ |
615
|
|
|
|
|
|
|
$ord = 3; |
616
|
|
|
|
|
|
|
} |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
if ($ord == 0){ |
619
|
|
|
|
|
|
|
$m->lange(1); |
620
|
|
|
|
|
|
|
} |
621
|
|
|
|
|
|
|
elsif($ord == 1){ |
622
|
|
|
|
|
|
|
$m->lange(2); |
623
|
|
|
|
|
|
|
} |
624
|
|
|
|
|
|
|
elsif($ord == 3){ |
625
|
|
|
|
|
|
|
$m->lange(3); |
626
|
|
|
|
|
|
|
} |
627
|
|
|
|
|
|
|
else{ |
628
|
|
|
|
|
|
|
my ($sv, $info, $err); |
629
|
|
|
|
|
|
|
$err = setlaerror(NO); |
630
|
|
|
|
|
|
|
($sv, $info) = $m->msvd(0, 0); |
631
|
|
|
|
|
|
|
setlaerror($err); |
632
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
633
|
|
|
|
|
|
|
my ($index,@list); |
634
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
635
|
|
|
|
|
|
|
@list = $index->list; |
636
|
|
|
|
|
|
|
laerror("mnorm: SVD algorithm did not converge for matrix (PDL(s) @list): \$info = $info"); |
637
|
|
|
|
|
|
|
} |
638
|
|
|
|
|
|
|
$sv->slice('(0)')->reshape(-1)->sever; |
639
|
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
} |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
sub PDL::Complex::mnorm { |
645
|
|
|
|
|
|
|
my ($m, $ord) = @_; |
646
|
|
|
|
|
|
|
$ord = 2 unless (defined $ord); |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
if ($ord eq 'inf'){ |
649
|
|
|
|
|
|
|
$ord = 0; |
650
|
|
|
|
|
|
|
} |
651
|
|
|
|
|
|
|
elsif ($ord eq 'one'){ |
652
|
|
|
|
|
|
|
$ord = 1; |
653
|
|
|
|
|
|
|
} |
654
|
|
|
|
|
|
|
elsif($ord eq 'two'){ |
655
|
|
|
|
|
|
|
$ord = 2; |
656
|
|
|
|
|
|
|
} |
657
|
|
|
|
|
|
|
elsif($ord eq 'fro'){ |
658
|
|
|
|
|
|
|
$ord = 3; |
659
|
|
|
|
|
|
|
} |
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
if ($ord == 0){ |
662
|
|
|
|
|
|
|
return bless $m->clange(1),'PDL'; |
663
|
|
|
|
|
|
|
} |
664
|
|
|
|
|
|
|
elsif($ord == 1){ |
665
|
|
|
|
|
|
|
return bless $m->clange(2),'PDL'; |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
elsif($ord == 3){ |
668
|
|
|
|
|
|
|
return bless $m->clange(3),'PDL'; |
669
|
|
|
|
|
|
|
} |
670
|
|
|
|
|
|
|
else{ |
671
|
|
|
|
|
|
|
my ($sv, $info, $err) ; |
672
|
|
|
|
|
|
|
$err = setlaerror(NO); |
673
|
|
|
|
|
|
|
($sv, $info) = $m->msvd(0, 0); |
674
|
|
|
|
|
|
|
setlaerror($err); |
675
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
676
|
|
|
|
|
|
|
my ($index,@list); |
677
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
678
|
|
|
|
|
|
|
@list = $index->list; |
679
|
|
|
|
|
|
|
laerror("mnorm: SVD algorithm did not converge for matrix (PDL(s) @list): \$info = $info"); |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
$sv->slice('(0)')->reshape(-1)->sever; |
682
|
|
|
|
|
|
|
} |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
=head2 mdet |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
=for ref |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
Computes determinant of a general square matrix using LU factorization. |
693
|
|
|
|
|
|
|
Supports threading. |
694
|
|
|
|
|
|
|
Uses L or L |
695
|
|
|
|
|
|
|
from Lapack. |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
=for usage |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
PDL(determinant) = mdet(PDL); |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
=for example |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
my $a = random(10,10); |
704
|
|
|
|
|
|
|
my $det = mdet($a); |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
=cut |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
sub mdet{ |
709
|
|
|
|
|
|
|
my $m =shift; |
710
|
|
|
|
|
|
|
$m->mdet; |
711
|
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
sub PDL::mdet { |
715
|
|
|
|
|
|
|
my $m = shift; |
716
|
|
|
|
|
|
|
my @dims = $m->dims; |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
barf("mdet: Require square array(s)") |
719
|
|
|
|
|
|
|
unless( $dims[0] == $dims[1] && @dims >= 2); |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
my ($info, $ipiv); |
722
|
|
|
|
|
|
|
$m = $m->copy(); |
723
|
|
|
|
|
|
|
$info = null; |
724
|
|
|
|
|
|
|
$ipiv = null; |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
$m->getrf($ipiv, $info); |
727
|
|
|
|
|
|
|
$m = $m->diagonal(0,1)->prodover; |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
$m = $m * ((PDL::Ufunc::sumover(sequence($ipiv->dim(0))->plus(1,0) != $ipiv)%2)*(-2)+1) ; |
730
|
|
|
|
|
|
|
$info = $m->flat->index(which($info != 0 )); |
731
|
|
|
|
|
|
|
$info .= 0 unless $info->isempty; |
732
|
|
|
|
|
|
|
$m; |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
|
736
|
|
|
|
|
|
|
sub PDL::Complex::mdet { |
737
|
|
|
|
|
|
|
my $m = shift; |
738
|
|
|
|
|
|
|
my @dims = $m->dims; |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
barf("mdet: Require square array(s)") |
741
|
|
|
|
|
|
|
unless( @dims >= 3 && $dims[1] == $dims[2] ); |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
my ($info, $ipiv); |
744
|
|
|
|
|
|
|
$m = $m->copy(); |
745
|
|
|
|
|
|
|
$info = null; |
746
|
|
|
|
|
|
|
$ipiv = null; |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
$m->cgetrf($ipiv, $info); |
749
|
|
|
|
|
|
|
$m = PDL::Complex::Cprodover($m->diagonal(1,2)); |
750
|
|
|
|
|
|
|
$m = $m * ((PDL::Ufunc::sumover(sequence($ipiv->dim(0))->plus(1,0) != $ipiv)%2)*(-2)+1) ; |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
$info = which($info != 0 ); |
753
|
|
|
|
|
|
|
unless ($info->isempty){ |
754
|
|
|
|
|
|
|
$m->re->flat->index($info) .= 0; |
755
|
|
|
|
|
|
|
$m->im->flat->index($info) .= 0; |
756
|
|
|
|
|
|
|
} |
757
|
|
|
|
|
|
|
$m; |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
} |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
=head2 mposdet |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
=for ref |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
Compute determinant of a symmetric or Hermitian positive definite square matrix using Cholesky factorization. |
767
|
|
|
|
|
|
|
Supports threading. |
768
|
|
|
|
|
|
|
Uses L or L from Lapack. |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
=for usage |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
(PDL, PDL) = mposdet(PDL, SCALAR) |
773
|
|
|
|
|
|
|
SCALAR : UPPER = 0 | LOWER = 1, default = 0 |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
=for example |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
my $a = random(10,10); |
778
|
|
|
|
|
|
|
my $det = mposdet($a); |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
=cut |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
sub mposdet{ |
783
|
|
|
|
|
|
|
my $m =shift; |
784
|
|
|
|
|
|
|
$m->mposdet(@_); |
785
|
|
|
|
|
|
|
} |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
sub PDL::mposdet { |
788
|
|
|
|
|
|
|
my ($m, $upper) = @_; |
789
|
|
|
|
|
|
|
my @dims = $m->dims; |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
barf("mposdet: Require square array(s)") |
792
|
|
|
|
|
|
|
unless( @dims >= 2 && $dims[0] == $dims[1] ); |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
$m = $m->copy(); |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
$m->potrf($upper, (my $info=null)); |
797
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
798
|
|
|
|
|
|
|
my ($index,@list); |
799
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
800
|
|
|
|
|
|
|
@list = $index->list; |
801
|
|
|
|
|
|
|
laerror("mposdet: Matrix (PDL(s) @list) is/are not positive definite(s) (after potrf factorization): \$info = $info"); |
802
|
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
|
$m = $m->diagonal(0,1)->prodover->pow(2); |
804
|
|
|
|
|
|
|
return wantarray ? ($m, $info) : $m; |
805
|
|
|
|
|
|
|
} |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
sub PDL::Complex::mposdet { |
808
|
|
|
|
|
|
|
my ($m, $upper) = @_; |
809
|
|
|
|
|
|
|
my @dims = $m->dims; |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
barf("mposdet: Require square array(s)") |
812
|
|
|
|
|
|
|
unless( @dims >= 3 && $dims[1] == $dims[2] ); |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
$m = $m->copy(); |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
$m->cpotrf($upper, (my $info=null)); |
817
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
818
|
|
|
|
|
|
|
my ($index,@list); |
819
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
820
|
|
|
|
|
|
|
@list = $index->list; |
821
|
|
|
|
|
|
|
laerror("mposdet: Matrix (PDL(s) @list) is/are not positive definite(s) (after cpotrf factorization): \$info = $info"); |
822
|
|
|
|
|
|
|
} |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
$m = PDL::Complex::re($m)->diagonal(0,1)->prodover->pow(2); |
825
|
|
|
|
|
|
|
return wantarray ? ($m, $info) : $m; |
826
|
|
|
|
|
|
|
} |
827
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
=head2 mcond |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
=for ref |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
Computes the condition number (two-norm) of a general matrix. |
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
The condition number in two-n is defined: |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
norm (a) * norm (inv (a)). |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
Uses a singular value decomposition. |
840
|
|
|
|
|
|
|
Supports threading. |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
=for usage |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
PDL = mcond(PDL) |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
=for example |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
my $a = random(10,10); |
849
|
|
|
|
|
|
|
my $cond = mcond($a); |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
=cut |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
sub mcond{ |
854
|
|
|
|
|
|
|
my $m =shift; |
855
|
|
|
|
|
|
|
$m->mcond(@_); |
856
|
|
|
|
|
|
|
} |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
sub PDL::mcond { |
859
|
|
|
|
|
|
|
my $m = shift; |
860
|
|
|
|
|
|
|
my @dims = $m->dims; |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
barf("mcond: Require 2D array(s)") |
863
|
|
|
|
|
|
|
unless( @dims >= 2 ); |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
my ($sv, $info, $err, $ret, $temp); |
866
|
|
|
|
|
|
|
$err = setlaerror(NO); |
867
|
|
|
|
|
|
|
($sv, $info) = $m->msvd(0, 0); |
868
|
|
|
|
|
|
|
setlaerror($err); |
869
|
|
|
|
|
|
|
if($info->max > 0) { |
870
|
|
|
|
|
|
|
my ($index,@list); |
871
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
872
|
|
|
|
|
|
|
@list = $index->list; |
873
|
|
|
|
|
|
|
barf("mcond: Algorithm did not converge for matrix (PDL(s) @list): \$info = $info"); |
874
|
|
|
|
|
|
|
} |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
$temp = $sv->slice('(0)'); |
877
|
|
|
|
|
|
|
$ret = $temp/$sv->((-1)); |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
$info = $ret->flat->index(which($temp == 0)); |
880
|
|
|
|
|
|
|
$info .= posinf unless $info->isempty; |
881
|
|
|
|
|
|
|
return $ret; |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
} |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
sub PDL::Complex::mcond { |
886
|
|
|
|
|
|
|
my $m = shift; |
887
|
|
|
|
|
|
|
my @dims = $m->dims; |
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
barf("mcond: Require 2D array(s)") |
890
|
|
|
|
|
|
|
unless( @dims >= 3); |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
my ($sv, $info, $err, $ret, $temp) ; |
893
|
|
|
|
|
|
|
$err = setlaerror(NO); |
894
|
|
|
|
|
|
|
($sv, $info) = $m->msvd(0, 0); |
895
|
|
|
|
|
|
|
setlaerror($err); |
896
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
897
|
|
|
|
|
|
|
my ($index,@list); |
898
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
899
|
|
|
|
|
|
|
@list = $index->list; |
900
|
|
|
|
|
|
|
laerror("mcond: Algorithm did not converge for matrix (PDL(s) @list): \$info = $info"); |
901
|
|
|
|
|
|
|
} |
902
|
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
$temp = $sv->slice('(0)'); |
904
|
|
|
|
|
|
|
$ret = $temp/$sv->((-1)); |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
$info = $ret->flat->index(which($temp == 0)); |
907
|
|
|
|
|
|
|
$info .= posinf unless $info->isempty; |
908
|
|
|
|
|
|
|
return $ret; |
909
|
|
|
|
|
|
|
} |
910
|
|
|
|
|
|
|
|
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
=head2 mrcond |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
=for ref |
916
|
|
|
|
|
|
|
|
917
|
|
|
|
|
|
|
Estimates the reciprocal condition number of a |
918
|
|
|
|
|
|
|
general square matrix using LU factorization |
919
|
|
|
|
|
|
|
in either the 1-norm or the infinity-norm. |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
The reciprocal condition number is defined: |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
1/(norm (a) * norm (inv (a))) |
924
|
|
|
|
|
|
|
|
925
|
|
|
|
|
|
|
Supports threading. |
926
|
|
|
|
|
|
|
Works on transposed array(s) |
927
|
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
=for usage |
929
|
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
PDL = mrcond(PDL, SCALAR(ord)) |
931
|
|
|
|
|
|
|
ord : |
932
|
|
|
|
|
|
|
0 : Infinity norm (default) |
933
|
|
|
|
|
|
|
1 : One norm |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
=for example |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
my $a = random(10,10); |
938
|
|
|
|
|
|
|
my $rcond = mrcond($a,1); |
939
|
|
|
|
|
|
|
|
940
|
|
|
|
|
|
|
=cut |
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
sub mrcond{ |
943
|
|
|
|
|
|
|
my $m =shift; |
944
|
|
|
|
|
|
|
$m->mcond(@_); |
945
|
|
|
|
|
|
|
} |
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
sub PDL::mrcond { |
948
|
|
|
|
|
|
|
my ($m,$anorm) = @_; |
949
|
|
|
|
|
|
|
$anorm = 0 unless defined $anorm; |
950
|
|
|
|
|
|
|
my @dims = $m->dims; |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
barf("mrcond: Require square array") |
953
|
|
|
|
|
|
|
unless ( $dims[0] == $dims[1] ); |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
my ($ipiv, $info,$rcond,$norm); |
956
|
|
|
|
|
|
|
$norm = $m->mnorm($anorm); |
957
|
|
|
|
|
|
|
$m = $m->xchg(0,1)->copy(); |
958
|
|
|
|
|
|
|
$ipiv = PDL->null; |
959
|
|
|
|
|
|
|
$info = PDL->null; |
960
|
|
|
|
|
|
|
$rcond = PDL->null; |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
$m->getrf($ipiv, $info); |
963
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
964
|
|
|
|
|
|
|
my ($index,@list); |
965
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
966
|
|
|
|
|
|
|
@list = $index->list; |
967
|
|
|
|
|
|
|
laerror("mrcond: Factor(s) U (PDL(s) @list) is/are singular(s) (after getrf factorization): \$info = $info"); |
968
|
|
|
|
|
|
|
} |
969
|
|
|
|
|
|
|
else{ |
970
|
|
|
|
|
|
|
$m->gecon($anorm,$norm,$rcond,$info); |
971
|
|
|
|
|
|
|
} |
972
|
|
|
|
|
|
|
return wantarray ? ($rcond, $info) : $rcond; |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
} |
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
sub PDL::Complex::mrcond { |
978
|
|
|
|
|
|
|
my ($m, $anorm) = @_; |
979
|
|
|
|
|
|
|
$anorm = 0 unless defined $anorm; |
980
|
|
|
|
|
|
|
my @dims = $m->dims; |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
barf("mrcond: Require square array(s)") |
983
|
|
|
|
|
|
|
unless ( $dims[1] == $dims[2] ); |
984
|
|
|
|
|
|
|
|
985
|
|
|
|
|
|
|
my ($ipiv, $info,$rcond,$norm); |
986
|
|
|
|
|
|
|
$norm = $m->mnorm($anorm); |
987
|
|
|
|
|
|
|
$m = $m->xchg(1,2)->copy(); |
988
|
|
|
|
|
|
|
$ipiv = PDL->null; |
989
|
|
|
|
|
|
|
$info = PDL->null; |
990
|
|
|
|
|
|
|
$rcond = PDL->null; |
991
|
|
|
|
|
|
|
|
992
|
|
|
|
|
|
|
$m->cgetrf($ipiv, $info); |
993
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
994
|
|
|
|
|
|
|
my ($index,@list); |
995
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
996
|
|
|
|
|
|
|
@list = $index->list; |
997
|
|
|
|
|
|
|
laerror("mrcond: Factor(s) U (PDL(s) @list) is/are singular(s) (after cgetrf factorization) : \$info = $info"); |
998
|
|
|
|
|
|
|
} |
999
|
|
|
|
|
|
|
else{ |
1000
|
|
|
|
|
|
|
$m->cgecon($anorm,$norm,$rcond,$info); |
1001
|
|
|
|
|
|
|
} |
1002
|
|
|
|
|
|
|
return wantarray ? ($rcond, $info) : $rcond; |
1003
|
|
|
|
|
|
|
|
1004
|
|
|
|
|
|
|
} |
1005
|
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
|
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
=head2 morth |
1011
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
=for ref |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
Returns an orthonormal basis of the range space of matrix A. |
1015
|
|
|
|
|
|
|
|
1016
|
|
|
|
|
|
|
=for usage |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
PDL = morth(PDL(A), SCALAR(tol)) |
1019
|
|
|
|
|
|
|
tol : tolerance for determining rank, default: 1e-8 for double else 1e-5 |
1020
|
|
|
|
|
|
|
|
1021
|
|
|
|
|
|
|
=for example |
1022
|
|
|
|
|
|
|
|
1023
|
|
|
|
|
|
|
my $a = sequence(10,10); |
1024
|
|
|
|
|
|
|
my $ortho = morth($a, 1e-8); |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
=cut |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
*morth = \&PDL::morth; |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
sub PDL::morth { |
1031
|
|
|
|
|
|
|
my ($m, $tol) = @_; |
1032
|
|
|
|
|
|
|
my @dims = $m->dims; |
1033
|
|
|
|
|
|
|
barf("morth: Require a matrix") |
1034
|
|
|
|
|
|
|
unless( (@dims == 2) || (@dims == 3)); |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
my ($u, $s, $rank, $info, $err); |
1037
|
|
|
|
|
|
|
$tol = (defined $tol) ? $tol : ($m->type == double) ? 1e-8 : 1e-5; |
1038
|
|
|
|
|
|
|
|
1039
|
|
|
|
|
|
|
$err = setlaerror(NO); |
1040
|
|
|
|
|
|
|
($u, $s, undef, $info) = $m->mdsvd; |
1041
|
|
|
|
|
|
|
setlaerror($err); |
1042
|
|
|
|
|
|
|
barf("morth: SVD algorithm did not converge\n") if $info; |
1043
|
|
|
|
|
|
|
|
1044
|
|
|
|
|
|
|
$rank = (which($s > $tol))->dim(0) - 1; |
1045
|
|
|
|
|
|
|
if(@dims == 3){ |
1046
|
|
|
|
|
|
|
return $rank < 0 ? PDL::Complex->null : $u(,:$rank,)->sever; |
1047
|
|
|
|
|
|
|
} |
1048
|
|
|
|
|
|
|
else{ |
1049
|
|
|
|
|
|
|
return $rank < 0 ? null : $u(:$rank,)->sever; |
1050
|
|
|
|
|
|
|
} |
1051
|
|
|
|
|
|
|
} |
1052
|
|
|
|
|
|
|
|
1053
|
|
|
|
|
|
|
=head2 mnull |
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
=for ref |
1056
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
Returns an orthonormal basis of the null space of matrix A. |
1058
|
|
|
|
|
|
|
Works on transposed array. |
1059
|
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
|
=for usage |
1061
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
PDL = mnull(PDL(A), SCALAR(tol)) |
1063
|
|
|
|
|
|
|
tol : tolerance for determining rank, default: 1e-8 for double else 1e-5 |
1064
|
|
|
|
|
|
|
|
1065
|
|
|
|
|
|
|
=for example |
1066
|
|
|
|
|
|
|
|
1067
|
|
|
|
|
|
|
my $a = sequence(10,10); |
1068
|
|
|
|
|
|
|
my $null = mnull($a, 1e-8); |
1069
|
|
|
|
|
|
|
|
1070
|
|
|
|
|
|
|
=cut |
1071
|
|
|
|
|
|
|
|
1072
|
|
|
|
|
|
|
*mnull = \&PDL::mnull; |
1073
|
|
|
|
|
|
|
|
1074
|
|
|
|
|
|
|
sub PDL::mnull { |
1075
|
|
|
|
|
|
|
my ($m, $tol) = @_; |
1076
|
|
|
|
|
|
|
my @dims = $m->dims; |
1077
|
|
|
|
|
|
|
barf("mnull: Require a matrix") |
1078
|
|
|
|
|
|
|
unless( (@dims == 2) || (@dims == 3)); |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
my ($v, $s, $rank, $info, $err); |
1081
|
|
|
|
|
|
|
$tol = (defined $tol) ? $tol : ($m->type == double) ? 1e-8 : 1e-5; |
1082
|
|
|
|
|
|
|
|
1083
|
|
|
|
|
|
|
$err = setlaerror(NO); |
1084
|
|
|
|
|
|
|
(undef, $s, $v, $info) = $m->mdsvd; |
1085
|
|
|
|
|
|
|
setlaerror($err); |
1086
|
|
|
|
|
|
|
barf("mnull: SVD algorithm did not converge\n") if $info; |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
#TODO: USE TRANSPOSED A |
1089
|
|
|
|
|
|
|
$rank = (which($s > $tol))->dim(0); |
1090
|
|
|
|
|
|
|
if (@dims == 3){ |
1091
|
|
|
|
|
|
|
return $rank < $dims[1] ? $v->(,,$rank:)->t : PDL::Complex->null; |
1092
|
|
|
|
|
|
|
} |
1093
|
|
|
|
|
|
|
else{ |
1094
|
|
|
|
|
|
|
return $rank < $dims[1] ? $v->xchg(0,1)->($rank:,)->sever : null; |
1095
|
|
|
|
|
|
|
} |
1096
|
|
|
|
|
|
|
} |
1097
|
|
|
|
|
|
|
|
1098
|
|
|
|
|
|
|
|
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
=head2 minv |
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
=for ref |
1103
|
|
|
|
|
|
|
|
1104
|
|
|
|
|
|
|
Computes inverse of a general square matrix using LU factorization. Supports inplace and threading. |
1105
|
|
|
|
|
|
|
Uses L and L |
1106
|
|
|
|
|
|
|
or L and L |
1107
|
|
|
|
|
|
|
from Lapack and returns C in array context. |
1108
|
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
|
=for usage |
1110
|
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
|
PDL(inv) = minv(PDL) |
1112
|
|
|
|
|
|
|
|
1113
|
|
|
|
|
|
|
=for example |
1114
|
|
|
|
|
|
|
|
1115
|
|
|
|
|
|
|
my $a = random(10,10); |
1116
|
|
|
|
|
|
|
my $inv = minv($a); |
1117
|
|
|
|
|
|
|
|
1118
|
|
|
|
|
|
|
=cut |
1119
|
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
|
sub minv($) { |
1121
|
|
|
|
|
|
|
$_[0]->minv; |
1122
|
|
|
|
|
|
|
} |
1123
|
|
|
|
|
|
|
sub PDL::minv { |
1124
|
|
|
|
|
|
|
my $m = shift; |
1125
|
|
|
|
|
|
|
my @dims = $m->dims; |
1126
|
|
|
|
|
|
|
my ($ipiv, $info); |
1127
|
|
|
|
|
|
|
|
1128
|
|
|
|
|
|
|
barf("minv: Require square array(s)") |
1129
|
|
|
|
|
|
|
if( $dims[0] != $dims[1] ); |
1130
|
|
|
|
|
|
|
|
1131
|
|
|
|
|
|
|
$m = $m->copy() unless $m->is_inplace(0); |
1132
|
|
|
|
|
|
|
$ipiv = PDL->null; |
1133
|
|
|
|
|
|
|
$info = PDL->null; |
1134
|
|
|
|
|
|
|
|
1135
|
|
|
|
|
|
|
$m->getrf($ipiv, $info); |
1136
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
1137
|
|
|
|
|
|
|
my ($index,@list); |
1138
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
1139
|
|
|
|
|
|
|
@list = $index->list; |
1140
|
|
|
|
|
|
|
laerror("minv: Factor(s) U (PDL(s) @list) is/are singular(s) (after getrf factorization): \$info = $info"); |
1141
|
|
|
|
|
|
|
} |
1142
|
|
|
|
|
|
|
$m->getri($ipiv,$info); |
1143
|
|
|
|
|
|
|
return wantarray ? ($m, $info) : $m; |
1144
|
|
|
|
|
|
|
} |
1145
|
|
|
|
|
|
|
sub PDL::Complex::minv { |
1146
|
|
|
|
|
|
|
my $m = shift; |
1147
|
|
|
|
|
|
|
my @dims = $m->dims; |
1148
|
|
|
|
|
|
|
my ($ipiv, $info); |
1149
|
|
|
|
|
|
|
|
1150
|
|
|
|
|
|
|
barf("minv: Require square array(s)") |
1151
|
|
|
|
|
|
|
if( $dims[1] != $dims[2] ); |
1152
|
|
|
|
|
|
|
|
1153
|
|
|
|
|
|
|
$m = $m->copy() unless $m->is_inplace(0); |
1154
|
|
|
|
|
|
|
$ipiv = PDL->null; |
1155
|
|
|
|
|
|
|
$info = PDL->null; |
1156
|
|
|
|
|
|
|
|
1157
|
|
|
|
|
|
|
$m->cgetrf($ipiv, $info); |
1158
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
1159
|
|
|
|
|
|
|
my ($index,@list); |
1160
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
1161
|
|
|
|
|
|
|
@list = $index->list; |
1162
|
|
|
|
|
|
|
laerror("minv: Factor(s) U (PDL(s) @list) is/are singular(s) (after cgetrf factorization) : \$info = $info"); |
1163
|
|
|
|
|
|
|
} |
1164
|
|
|
|
|
|
|
else{ |
1165
|
|
|
|
|
|
|
$m->cgetri($ipiv,$info); |
1166
|
|
|
|
|
|
|
} |
1167
|
|
|
|
|
|
|
return wantarray ? ($m, $info) : $m; |
1168
|
|
|
|
|
|
|
} |
1169
|
|
|
|
|
|
|
|
1170
|
|
|
|
|
|
|
=head2 mtriinv |
1171
|
|
|
|
|
|
|
|
1172
|
|
|
|
|
|
|
=for ref |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
Computes inverse of a triangular matrix. Supports inplace and threading. |
1175
|
|
|
|
|
|
|
Uses L or L from Lapack. |
1176
|
|
|
|
|
|
|
Returns C in array context. |
1177
|
|
|
|
|
|
|
|
1178
|
|
|
|
|
|
|
=for usage |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
(PDL, PDL(info))) = mtriinv(PDL, SCALAR(uplo), SCALAR|PDL(diag)) |
1181
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1, default = 0 |
1182
|
|
|
|
|
|
|
diag : UNITARY DIAGONAL = 1, default = 0 |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
=for example |
1185
|
|
|
|
|
|
|
|
1186
|
|
|
|
|
|
|
# Assume $a is upper triangular |
1187
|
|
|
|
|
|
|
my $a = random(10,10); |
1188
|
|
|
|
|
|
|
my $inv = mtriinv($a); |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
=cut |
1191
|
|
|
|
|
|
|
|
1192
|
|
|
|
|
|
|
|
1193
|
|
|
|
|
|
|
sub mtriinv{ |
1194
|
|
|
|
|
|
|
my $m = shift; |
1195
|
|
|
|
|
|
|
$m->mtriinv(@_); |
1196
|
|
|
|
|
|
|
} |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
sub PDL::mtriinv{ |
1199
|
|
|
|
|
|
|
my $m = shift; |
1200
|
|
|
|
|
|
|
my $upper = @_ ? (1 - shift) : pdl (long,1); |
1201
|
|
|
|
|
|
|
my $diag = shift; |
1202
|
|
|
|
|
|
|
|
1203
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
1204
|
|
|
|
|
|
|
|
1205
|
|
|
|
|
|
|
barf("mtriinv: Require square array(s)") |
1206
|
|
|
|
|
|
|
if( $dims[0] != $dims[1] ); |
1207
|
|
|
|
|
|
|
|
1208
|
|
|
|
|
|
|
$m = $m->copy() unless $m->is_inplace(0); |
1209
|
|
|
|
|
|
|
my $info = PDL->null; |
1210
|
|
|
|
|
|
|
$m->trtri($upper, $diag, $info); |
1211
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
1212
|
|
|
|
|
|
|
my ($index,@list); |
1213
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
1214
|
|
|
|
|
|
|
@list = $index->list; |
1215
|
|
|
|
|
|
|
laerror("mtriinv: Matrix (PDL(s) @list) is/are singular(s): \$info = $info"); |
1216
|
|
|
|
|
|
|
} |
1217
|
|
|
|
|
|
|
return wantarray ? ($m, $info) : $m; |
1218
|
|
|
|
|
|
|
} |
1219
|
|
|
|
|
|
|
|
1220
|
|
|
|
|
|
|
sub PDL::Complex::mtriinv{ |
1221
|
|
|
|
|
|
|
my $m = shift; |
1222
|
|
|
|
|
|
|
my $upper = @_ ? (1 - shift) : pdl (long,1); |
1223
|
|
|
|
|
|
|
my $diag = shift; |
1224
|
|
|
|
|
|
|
|
1225
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
1226
|
|
|
|
|
|
|
|
1227
|
|
|
|
|
|
|
barf("mtriinv: Require square array(s)") |
1228
|
|
|
|
|
|
|
if( $dims[1] != $dims[2] ); |
1229
|
|
|
|
|
|
|
|
1230
|
|
|
|
|
|
|
$m = $m->copy() unless $m->is_inplace(0); |
1231
|
|
|
|
|
|
|
my $info = PDL->null; |
1232
|
|
|
|
|
|
|
$m->ctrtri($upper, $diag, $info); |
1233
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
1234
|
|
|
|
|
|
|
my ($index,@list); |
1235
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
1236
|
|
|
|
|
|
|
@list = $index->list; |
1237
|
|
|
|
|
|
|
laerror("mtriinv: Matrix (PDL(s) @list) is/are singular(s): \$info = $info"); |
1238
|
|
|
|
|
|
|
} |
1239
|
|
|
|
|
|
|
return wantarray ? ($m, $info) : $m; |
1240
|
|
|
|
|
|
|
} |
1241
|
|
|
|
|
|
|
|
1242
|
|
|
|
|
|
|
=head2 msyminv |
1243
|
|
|
|
|
|
|
|
1244
|
|
|
|
|
|
|
=for ref |
1245
|
|
|
|
|
|
|
|
1246
|
|
|
|
|
|
|
Computes inverse of a symmetric square matrix using the Bunch-Kaufman diagonal pivoting method. |
1247
|
|
|
|
|
|
|
Supports inplace and threading. |
1248
|
|
|
|
|
|
|
Uses L and L or |
1249
|
|
|
|
|
|
|
L and L |
1250
|
|
|
|
|
|
|
from Lapack and returns C in array context. |
1251
|
|
|
|
|
|
|
|
1252
|
|
|
|
|
|
|
=for usage |
1253
|
|
|
|
|
|
|
|
1254
|
|
|
|
|
|
|
(PDL, (PDL(info))) = msyminv(PDL, SCALAR|PDL(uplo)) |
1255
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1, default = 0 |
1256
|
|
|
|
|
|
|
|
1257
|
|
|
|
|
|
|
=for example |
1258
|
|
|
|
|
|
|
|
1259
|
|
|
|
|
|
|
# Assume $a is symmetric |
1260
|
|
|
|
|
|
|
my $a = random(10,10); |
1261
|
|
|
|
|
|
|
my $inv = msyminv($a); |
1262
|
|
|
|
|
|
|
|
1263
|
|
|
|
|
|
|
=cut |
1264
|
|
|
|
|
|
|
|
1265
|
|
|
|
|
|
|
sub msyminv { |
1266
|
|
|
|
|
|
|
my $m = shift; |
1267
|
|
|
|
|
|
|
$m->msyminv(@_); |
1268
|
|
|
|
|
|
|
} |
1269
|
|
|
|
|
|
|
|
1270
|
|
|
|
|
|
|
sub PDL::msyminv { |
1271
|
|
|
|
|
|
|
my $m = shift; |
1272
|
|
|
|
|
|
|
my $upper = @_ ? (1 - shift) : pdl (long,1); |
1273
|
|
|
|
|
|
|
my ($ipiv , $info); |
1274
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
1275
|
|
|
|
|
|
|
|
1276
|
|
|
|
|
|
|
barf("msyminv: Require square array(s)") |
1277
|
|
|
|
|
|
|
if( $dims[0] != $dims[1] ); |
1278
|
|
|
|
|
|
|
|
1279
|
|
|
|
|
|
|
$m = $m->copy() unless $m->is_inplace(0); |
1280
|
|
|
|
|
|
|
|
1281
|
|
|
|
|
|
|
$ipiv = zeroes(long, @dims[1..$#dims]); |
1282
|
|
|
|
|
|
|
@dims = @dims[2..$#dims]; |
1283
|
|
|
|
|
|
|
$info = @dims ? zeroes(long,@dims) : pdl(long,0); |
1284
|
|
|
|
|
|
|
|
1285
|
|
|
|
|
|
|
$m->sytrf($upper, $ipiv, $info); |
1286
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
1287
|
|
|
|
|
|
|
my ($index,@list); |
1288
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
1289
|
|
|
|
|
|
|
@list = $index->list; |
1290
|
|
|
|
|
|
|
laerror("msyminv: Block diagonal matrix D (PDL(s) @list) is/are singular(s) (after sytrf factorization): \$info = $info"); |
1291
|
|
|
|
|
|
|
} |
1292
|
|
|
|
|
|
|
else{ |
1293
|
|
|
|
|
|
|
$m->sytri($upper,$ipiv,$info); |
1294
|
|
|
|
|
|
|
$m = $m->t->tritosym($upper); |
1295
|
|
|
|
|
|
|
} |
1296
|
|
|
|
|
|
|
return wantarray ? ($m, $info) : $m; |
1297
|
|
|
|
|
|
|
} |
1298
|
|
|
|
|
|
|
|
1299
|
|
|
|
|
|
|
sub PDL::Complex::msyminv { |
1300
|
|
|
|
|
|
|
my $m = shift; |
1301
|
|
|
|
|
|
|
my $upper = @_ ? (1 - shift) : pdl (long,1); |
1302
|
|
|
|
|
|
|
my ($ipiv , $info); |
1303
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
1304
|
|
|
|
|
|
|
|
1305
|
|
|
|
|
|
|
barf("msyminv: Require square array(s)") |
1306
|
|
|
|
|
|
|
if( $dims[1] != $dims[2] ); |
1307
|
|
|
|
|
|
|
|
1308
|
|
|
|
|
|
|
$m = $m->copy() unless $m->is_inplace(0); |
1309
|
|
|
|
|
|
|
|
1310
|
|
|
|
|
|
|
$ipiv = zeroes(long, @dims[2..$#dims]); |
1311
|
|
|
|
|
|
|
@dims = @dims[3..$#dims]; |
1312
|
|
|
|
|
|
|
$info = @dims ? zeroes(long,@dims) : pdl(long,0); |
1313
|
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
|
$m->csytrf($upper, $ipiv, $info); |
1315
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
1316
|
|
|
|
|
|
|
my ($index,@list); |
1317
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
1318
|
|
|
|
|
|
|
@list = $index->list; |
1319
|
|
|
|
|
|
|
laerror("msyminv: Block diagonal matrix D (PDL(s) @list) is/are singular(s) (after csytrf factorization): \$info = $info"); |
1320
|
|
|
|
|
|
|
} |
1321
|
|
|
|
|
|
|
else{ |
1322
|
|
|
|
|
|
|
$m->csytri($upper,$ipiv,$info); |
1323
|
|
|
|
|
|
|
$m = $m->xchg(1,2)->tritosym($upper, 0); |
1324
|
|
|
|
|
|
|
} |
1325
|
|
|
|
|
|
|
return wantarray ? ($m, $info) : $m; |
1326
|
|
|
|
|
|
|
} |
1327
|
|
|
|
|
|
|
|
1328
|
|
|
|
|
|
|
=head2 mposinv |
1329
|
|
|
|
|
|
|
|
1330
|
|
|
|
|
|
|
=for ref |
1331
|
|
|
|
|
|
|
|
1332
|
|
|
|
|
|
|
Computes inverse of a symmetric positive definite square matrix using Cholesky factorization. |
1333
|
|
|
|
|
|
|
Supports inplace and threading. |
1334
|
|
|
|
|
|
|
Uses L and L or |
1335
|
|
|
|
|
|
|
L and L |
1336
|
|
|
|
|
|
|
from Lapack and returns C in array context. |
1337
|
|
|
|
|
|
|
|
1338
|
|
|
|
|
|
|
=for usage |
1339
|
|
|
|
|
|
|
|
1340
|
|
|
|
|
|
|
(PDL, (PDL(info))) = mposinv(PDL, SCALAR|PDL(uplo)) |
1341
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1, default = 0 |
1342
|
|
|
|
|
|
|
|
1343
|
|
|
|
|
|
|
=for example |
1344
|
|
|
|
|
|
|
|
1345
|
|
|
|
|
|
|
# Assume $a is symmetric positive definite |
1346
|
|
|
|
|
|
|
my $a = random(10,10); |
1347
|
|
|
|
|
|
|
$a = $a->crossprod($a); |
1348
|
|
|
|
|
|
|
my $inv = mposinv($a); |
1349
|
|
|
|
|
|
|
|
1350
|
|
|
|
|
|
|
=cut |
1351
|
|
|
|
|
|
|
|
1352
|
|
|
|
|
|
|
sub mposinv { |
1353
|
|
|
|
|
|
|
my $m = shift; |
1354
|
|
|
|
|
|
|
$m->mposinv(@_); |
1355
|
|
|
|
|
|
|
} |
1356
|
|
|
|
|
|
|
|
1357
|
|
|
|
|
|
|
sub PDL::mposinv { |
1358
|
|
|
|
|
|
|
my $m = shift; |
1359
|
|
|
|
|
|
|
my $upper = @_ ? (1 - shift) : pdl (long,1); |
1360
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
1361
|
|
|
|
|
|
|
|
1362
|
|
|
|
|
|
|
barf("mposinv: Require square array(s)") |
1363
|
|
|
|
|
|
|
unless( $dims[0] == $dims[1] ); |
1364
|
|
|
|
|
|
|
|
1365
|
|
|
|
|
|
|
$m = $m->copy() unless $m->is_inplace(0); |
1366
|
|
|
|
|
|
|
@dims = @dims[2..$#dims]; |
1367
|
|
|
|
|
|
|
my $info = @dims ? zeroes(long,@dims) : pdl(long,0); |
1368
|
|
|
|
|
|
|
|
1369
|
|
|
|
|
|
|
$m->potrf($upper, $info); |
1370
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
1371
|
|
|
|
|
|
|
my ($index,@list); |
1372
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
1373
|
|
|
|
|
|
|
@list = $index->list; |
1374
|
|
|
|
|
|
|
laerror("mposinv: matrix (PDL(s) @list) is/are not positive definite(s) (after potrf factorization): \$info = $info"); |
1375
|
|
|
|
|
|
|
} |
1376
|
|
|
|
|
|
|
else{ |
1377
|
|
|
|
|
|
|
$m->potri($upper, $info); |
1378
|
|
|
|
|
|
|
} |
1379
|
|
|
|
|
|
|
return wantarray ? ($m, $info) : $m; |
1380
|
|
|
|
|
|
|
} |
1381
|
|
|
|
|
|
|
|
1382
|
|
|
|
|
|
|
sub PDL::Complex::mposinv { |
1383
|
|
|
|
|
|
|
my $m = shift; |
1384
|
|
|
|
|
|
|
my $upper = @_ ? (1 - shift) : pdl (long,1); |
1385
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
1386
|
|
|
|
|
|
|
|
1387
|
|
|
|
|
|
|
|
1388
|
|
|
|
|
|
|
barf("mposinv: Require square array(s)") |
1389
|
|
|
|
|
|
|
unless( $dims[1] == $dims[2] ); |
1390
|
|
|
|
|
|
|
|
1391
|
|
|
|
|
|
|
$m = $m->copy() unless $m->is_inplace(0); |
1392
|
|
|
|
|
|
|
@dims = @dims[3..$#dims]; |
1393
|
|
|
|
|
|
|
my $info = @dims ? zeroes(long,@dims) : pdl(long,0); |
1394
|
|
|
|
|
|
|
|
1395
|
|
|
|
|
|
|
$m->cpotrf($upper, $info); |
1396
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
1397
|
|
|
|
|
|
|
my ($index,@list); |
1398
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
1399
|
|
|
|
|
|
|
@list = $index->list; |
1400
|
|
|
|
|
|
|
laerror("mposinv: matrix (PDL(s) @list) is/are not positive definite(s) (after cpotrf factorization): \$info = $info"); |
1401
|
|
|
|
|
|
|
} |
1402
|
|
|
|
|
|
|
else{ |
1403
|
|
|
|
|
|
|
$m->cpotri($upper, $info); |
1404
|
|
|
|
|
|
|
} |
1405
|
|
|
|
|
|
|
return wantarray ? ($m, $info) : $m; |
1406
|
|
|
|
|
|
|
} |
1407
|
|
|
|
|
|
|
|
1408
|
|
|
|
|
|
|
=head2 mpinv |
1409
|
|
|
|
|
|
|
|
1410
|
|
|
|
|
|
|
=for ref |
1411
|
|
|
|
|
|
|
|
1412
|
|
|
|
|
|
|
Computes pseudo-inverse (Moore-Penrose) of a general matrix. |
1413
|
|
|
|
|
|
|
Works on transposed array. |
1414
|
|
|
|
|
|
|
|
1415
|
|
|
|
|
|
|
=for usage |
1416
|
|
|
|
|
|
|
|
1417
|
|
|
|
|
|
|
PDL(pseudo-inv) = mpinv(PDL, SCALAR(tol)) |
1418
|
|
|
|
|
|
|
TOL: tolerance value, default : mnorm(dims(PDL),'inf') * mnorm(PDL) * EPS |
1419
|
|
|
|
|
|
|
|
1420
|
|
|
|
|
|
|
=for example |
1421
|
|
|
|
|
|
|
|
1422
|
|
|
|
|
|
|
my $a = random(5,10); |
1423
|
|
|
|
|
|
|
my $inv = mpinv($a); |
1424
|
|
|
|
|
|
|
|
1425
|
|
|
|
|
|
|
=cut |
1426
|
|
|
|
|
|
|
|
1427
|
|
|
|
|
|
|
*mpinv = \&PDL::mpinv; |
1428
|
|
|
|
|
|
|
|
1429
|
|
|
|
|
|
|
sub PDL::mpinv{ |
1430
|
|
|
|
|
|
|
my ($m, $tol) = @_; |
1431
|
|
|
|
|
|
|
my @dims = $m->dims; |
1432
|
|
|
|
|
|
|
barf("mpinv: Require a matrix") |
1433
|
|
|
|
|
|
|
unless( @dims == 2 or @dims == 3 ); |
1434
|
|
|
|
|
|
|
|
1435
|
|
|
|
|
|
|
my ($ind, $cind, $u, $s, $v, $info, $err); |
1436
|
|
|
|
|
|
|
|
1437
|
|
|
|
|
|
|
$err = setlaerror(NO); |
1438
|
|
|
|
|
|
|
#TODO: don't transpose |
1439
|
|
|
|
|
|
|
($u, $s, $v, $info) = $m->mdsvd(2); |
1440
|
|
|
|
|
|
|
setlaerror($err); |
1441
|
|
|
|
|
|
|
laerror("mpinv: SVD algorithm did not converge\n") if $info; |
1442
|
|
|
|
|
|
|
|
1443
|
|
|
|
|
|
|
unless (defined $tol){ |
1444
|
|
|
|
|
|
|
$tol = ($dims[-1] > $dims[-2] ? $dims[-1] : $dims[-2]) * $s((0)) * lamch(pdl($m->type,3)); |
1445
|
|
|
|
|
|
|
} |
1446
|
|
|
|
|
|
|
|
1447
|
|
|
|
|
|
|
|
1448
|
|
|
|
|
|
|
($ind, $cind) = which_both( $s > $tol ); |
1449
|
|
|
|
|
|
|
$s->index($cind) .= 0 if defined $cind; |
1450
|
|
|
|
|
|
|
$s->index($ind) .= 1/$s->index($ind) ; |
1451
|
|
|
|
|
|
|
|
1452
|
|
|
|
|
|
|
$ind = (@dims == 3) ? ($v->t * $s->r2C ) x $u->t : |
1453
|
|
|
|
|
|
|
($v->xchg(0,1) * $s ) x $u->xchg(0,1); |
1454
|
|
|
|
|
|
|
return wantarray ? ($ind, $info) : $ind; |
1455
|
|
|
|
|
|
|
|
1456
|
|
|
|
|
|
|
} |
1457
|
|
|
|
|
|
|
|
1458
|
|
|
|
|
|
|
|
1459
|
|
|
|
|
|
|
|
1460
|
|
|
|
|
|
|
=head2 mlu |
1461
|
|
|
|
|
|
|
|
1462
|
|
|
|
|
|
|
=for ref |
1463
|
|
|
|
|
|
|
|
1464
|
|
|
|
|
|
|
Computes LU factorization. |
1465
|
|
|
|
|
|
|
Uses L or L |
1466
|
|
|
|
|
|
|
from Lapack and returns L, U, pivot and info. |
1467
|
|
|
|
|
|
|
Works on transposed array. |
1468
|
|
|
|
|
|
|
|
1469
|
|
|
|
|
|
|
=for usage |
1470
|
|
|
|
|
|
|
|
1471
|
|
|
|
|
|
|
(PDL(l), PDL(u), PDL(pivot), PDL(info)) = mlu(PDL) |
1472
|
|
|
|
|
|
|
|
1473
|
|
|
|
|
|
|
=for example |
1474
|
|
|
|
|
|
|
|
1475
|
|
|
|
|
|
|
my $a = random(10,10); |
1476
|
|
|
|
|
|
|
($l, $u, $pivot, $info) = mlu($a); |
1477
|
|
|
|
|
|
|
|
1478
|
|
|
|
|
|
|
=cut |
1479
|
|
|
|
|
|
|
|
1480
|
|
|
|
|
|
|
*mlu = \&PDL::mlu; |
1481
|
|
|
|
|
|
|
|
1482
|
|
|
|
|
|
|
sub PDL::mlu { |
1483
|
|
|
|
|
|
|
my $m = shift; |
1484
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
1485
|
|
|
|
|
|
|
barf("mlu: Require a matrix") |
1486
|
|
|
|
|
|
|
unless((@dims == 2) || (@dims == 3)); |
1487
|
|
|
|
|
|
|
my ($ipiv, $info, $l, $u); |
1488
|
|
|
|
|
|
|
|
1489
|
|
|
|
|
|
|
$m = $m->copy; |
1490
|
|
|
|
|
|
|
$info = pdl(long ,0); |
1491
|
|
|
|
|
|
|
$ipiv = zeroes(long, ($dims[-2] > $dims[-1] ? $dims[-1]: $dims[-2])); |
1492
|
|
|
|
|
|
|
|
1493
|
|
|
|
|
|
|
if (@dims == 3){ |
1494
|
|
|
|
|
|
|
$m->t->cgetrf($ipiv,$info); |
1495
|
|
|
|
|
|
|
if($info > 0) { |
1496
|
|
|
|
|
|
|
$info--; |
1497
|
|
|
|
|
|
|
laerror("mlu: Factor U is singular: U($info,$info) = 0 (after cgetrf factorization)"); |
1498
|
|
|
|
|
|
|
$u = $l = $m; |
1499
|
|
|
|
|
|
|
} |
1500
|
|
|
|
|
|
|
else{ |
1501
|
|
|
|
|
|
|
$u = $m->mtri; |
1502
|
|
|
|
|
|
|
$l = $m->mtri(1); |
1503
|
|
|
|
|
|
|
if ($dims[-1] > $dims[-2]){ |
1504
|
|
|
|
|
|
|
$u = $u(,,:($dims[0]-1)); |
1505
|
|
|
|
|
|
|
$l((0), :($dims[0]-1), :($dims[0]-1))->diagonal(0,1) .= 1; |
1506
|
|
|
|
|
|
|
$l((1), :($dims[0]-1), :($dims[0]-1))->diagonal(0,1) .= 0; |
1507
|
|
|
|
|
|
|
} |
1508
|
|
|
|
|
|
|
elsif($dims[-1] < $dims[-2]){ |
1509
|
|
|
|
|
|
|
$l = $l(,:($dims[1]-1),); |
1510
|
|
|
|
|
|
|
$l((0),,)->diagonal(0,1).=1; |
1511
|
|
|
|
|
|
|
$l((1),,)->diagonal(0,1).=0; |
1512
|
|
|
|
|
|
|
} |
1513
|
|
|
|
|
|
|
else{ |
1514
|
|
|
|
|
|
|
$l((0),,)->diagonal(0,1).=1; |
1515
|
|
|
|
|
|
|
$l((1),,)->diagonal(0,1).=0; |
1516
|
|
|
|
|
|
|
} |
1517
|
|
|
|
|
|
|
} |
1518
|
|
|
|
|
|
|
} |
1519
|
|
|
|
|
|
|
else{ |
1520
|
|
|
|
|
|
|
$m->t->getrf($ipiv,$info); |
1521
|
|
|
|
|
|
|
if($info > 0) { |
1522
|
|
|
|
|
|
|
$info--; |
1523
|
|
|
|
|
|
|
laerror("mlu: Factor U is singular: U($info,$info) = 0 (after getrf factorization)"); |
1524
|
|
|
|
|
|
|
$u = $l = $m; |
1525
|
|
|
|
|
|
|
} |
1526
|
|
|
|
|
|
|
else{ |
1527
|
|
|
|
|
|
|
$u = $m->mtri; |
1528
|
|
|
|
|
|
|
$l = $m->mtri(1); |
1529
|
|
|
|
|
|
|
if ($dims[1] > $dims[0]){ |
1530
|
|
|
|
|
|
|
$u = $u(,:($dims[0]-1))->sever; |
1531
|
|
|
|
|
|
|
$l( :($dims[0]-1), :($dims[0]-1))->diagonal(0,1) .= 1; |
1532
|
|
|
|
|
|
|
} |
1533
|
|
|
|
|
|
|
elsif($dims[1] < $dims[0]){ |
1534
|
|
|
|
|
|
|
$l = $l(:($dims[1]-1),)->sever; |
1535
|
|
|
|
|
|
|
$l->diagonal(0,1) .= 1; |
1536
|
|
|
|
|
|
|
} |
1537
|
|
|
|
|
|
|
else{ |
1538
|
|
|
|
|
|
|
$l->diagonal(0,1).=1; |
1539
|
|
|
|
|
|
|
} |
1540
|
|
|
|
|
|
|
} |
1541
|
|
|
|
|
|
|
} |
1542
|
|
|
|
|
|
|
$l, $u, $ipiv, $info; |
1543
|
|
|
|
|
|
|
} |
1544
|
|
|
|
|
|
|
|
1545
|
|
|
|
|
|
|
=head2 mchol |
1546
|
|
|
|
|
|
|
|
1547
|
|
|
|
|
|
|
=for ref |
1548
|
|
|
|
|
|
|
|
1549
|
|
|
|
|
|
|
Computes Cholesky decomposition of a symmetric matrix also knows as symmetric square root. |
1550
|
|
|
|
|
|
|
If inplace flag is set, overwrite the leading upper or lower triangular part of A else returns |
1551
|
|
|
|
|
|
|
triangular matrix. Returns C in array context. |
1552
|
|
|
|
|
|
|
Supports threading. |
1553
|
|
|
|
|
|
|
Uses L or L from Lapack. |
1554
|
|
|
|
|
|
|
|
1555
|
|
|
|
|
|
|
=for usage |
1556
|
|
|
|
|
|
|
|
1557
|
|
|
|
|
|
|
PDL(Cholesky) = mchol(PDL, SCALAR) |
1558
|
|
|
|
|
|
|
SCALAR : UPPER = 0 | LOWER = 1, default = 0 |
1559
|
|
|
|
|
|
|
|
1560
|
|
|
|
|
|
|
=for example |
1561
|
|
|
|
|
|
|
|
1562
|
|
|
|
|
|
|
my $a = random(10,10); |
1563
|
|
|
|
|
|
|
$a = crossprod($a, $a); |
1564
|
|
|
|
|
|
|
my $u = mchol($a); |
1565
|
|
|
|
|
|
|
|
1566
|
|
|
|
|
|
|
=cut |
1567
|
|
|
|
|
|
|
|
1568
|
|
|
|
|
|
|
sub mchol { |
1569
|
|
|
|
|
|
|
my $m = shift; |
1570
|
|
|
|
|
|
|
$m->mchol(@_); |
1571
|
|
|
|
|
|
|
} |
1572
|
|
|
|
|
|
|
|
1573
|
|
|
|
|
|
|
sub PDL::mchol { |
1574
|
|
|
|
|
|
|
my($m, $upper) = @_; |
1575
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
1576
|
|
|
|
|
|
|
barf("mchol: Require square array(s)") |
1577
|
|
|
|
|
|
|
if ( $dims[0] != $dims[1] ); |
1578
|
|
|
|
|
|
|
|
1579
|
|
|
|
|
|
|
my ($uplo, $info); |
1580
|
|
|
|
|
|
|
|
1581
|
|
|
|
|
|
|
$m = $m->mtri($upper) unless $m->is_inplace(0); |
1582
|
|
|
|
|
|
|
@dims = @dims[2..$#dims]; |
1583
|
|
|
|
|
|
|
$info = @dims ? zeroes(long,@dims) : pdl(long,0); |
1584
|
|
|
|
|
|
|
$uplo = 1 - $upper; |
1585
|
|
|
|
|
|
|
$m->potrf($uplo,$info); |
1586
|
|
|
|
|
|
|
|
1587
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
1588
|
|
|
|
|
|
|
my ($index,@list); |
1589
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
1590
|
|
|
|
|
|
|
@list = $index->list; |
1591
|
|
|
|
|
|
|
laerror("mchol: matrix (PDL(s) @list) is/are not positive definite(s) (after potrf factorization): \$info = $info"); |
1592
|
|
|
|
|
|
|
} |
1593
|
|
|
|
|
|
|
return wantarray ? ($m, $info) : $m; |
1594
|
|
|
|
|
|
|
|
1595
|
|
|
|
|
|
|
} |
1596
|
|
|
|
|
|
|
|
1597
|
|
|
|
|
|
|
sub PDL::Complex::mchol { |
1598
|
|
|
|
|
|
|
my($m, $upper) = @_; |
1599
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
1600
|
|
|
|
|
|
|
barf("mchol: Require square array(s)") |
1601
|
|
|
|
|
|
|
if ( $dims[1] != $dims[2] ); |
1602
|
|
|
|
|
|
|
|
1603
|
|
|
|
|
|
|
my ($uplo, $info); |
1604
|
|
|
|
|
|
|
|
1605
|
|
|
|
|
|
|
$m = $m->mtri($upper) unless $m->is_inplace(0); |
1606
|
|
|
|
|
|
|
@dims = @dims[3..$#dims]; |
1607
|
|
|
|
|
|
|
$info = @dims ? zeroes(long,@dims) : pdl(long,0); |
1608
|
|
|
|
|
|
|
$uplo = 1 - $upper; |
1609
|
|
|
|
|
|
|
$m->cpotrf($uplo,$info); |
1610
|
|
|
|
|
|
|
|
1611
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
1612
|
|
|
|
|
|
|
my ($index,@list); |
1613
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
1614
|
|
|
|
|
|
|
@list = $index->list; |
1615
|
|
|
|
|
|
|
laerror("mchol: matrix (PDL(s) @list) is/are not positive definite(s) (after cpotrf factorization): \$info = $info"); |
1616
|
|
|
|
|
|
|
} |
1617
|
|
|
|
|
|
|
return wantarray ? ($m, $info) : $m; |
1618
|
|
|
|
|
|
|
|
1619
|
|
|
|
|
|
|
} |
1620
|
|
|
|
|
|
|
|
1621
|
|
|
|
|
|
|
=head2 mhessen |
1622
|
|
|
|
|
|
|
|
1623
|
|
|
|
|
|
|
=for ref |
1624
|
|
|
|
|
|
|
|
1625
|
|
|
|
|
|
|
Reduces a square matrix to Hessenberg form H and orthogonal matrix Q. |
1626
|
|
|
|
|
|
|
|
1627
|
|
|
|
|
|
|
It reduces a general matrix A to upper Hessenberg form H by an orthogonal |
1628
|
|
|
|
|
|
|
similarity transformation: |
1629
|
|
|
|
|
|
|
|
1630
|
|
|
|
|
|
|
Q' x A x Q = H |
1631
|
|
|
|
|
|
|
|
1632
|
|
|
|
|
|
|
or |
1633
|
|
|
|
|
|
|
|
1634
|
|
|
|
|
|
|
A = Q x H x Q' |
1635
|
|
|
|
|
|
|
|
1636
|
|
|
|
|
|
|
Uses L and L or |
1637
|
|
|
|
|
|
|
L and L |
1638
|
|
|
|
|
|
|
from Lapack and returns C in scalar context else C and C. |
1639
|
|
|
|
|
|
|
Works on transposed array. |
1640
|
|
|
|
|
|
|
|
1641
|
|
|
|
|
|
|
=for usage |
1642
|
|
|
|
|
|
|
|
1643
|
|
|
|
|
|
|
(PDL(h), (PDL(q))) = mhessen(PDL) |
1644
|
|
|
|
|
|
|
|
1645
|
|
|
|
|
|
|
=for example |
1646
|
|
|
|
|
|
|
|
1647
|
|
|
|
|
|
|
my $a = random(10,10); |
1648
|
|
|
|
|
|
|
($h, $q) = mhessen($a); |
1649
|
|
|
|
|
|
|
|
1650
|
|
|
|
|
|
|
=cut |
1651
|
|
|
|
|
|
|
|
1652
|
|
|
|
|
|
|
*mhessen = \&PDL::mhessen; |
1653
|
|
|
|
|
|
|
|
1654
|
|
|
|
|
|
|
sub PDL::mhessen { |
1655
|
|
|
|
|
|
|
my $m = shift; |
1656
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
1657
|
|
|
|
|
|
|
barf("mhessen: Require a square matrix") |
1658
|
|
|
|
|
|
|
unless( ((@dims == 2) || (@dims == 3)) && $dims[-1] == $dims[-2] ); |
1659
|
|
|
|
|
|
|
|
1660
|
|
|
|
|
|
|
my ($info, $tau, $h, $q); |
1661
|
|
|
|
|
|
|
|
1662
|
|
|
|
|
|
|
$m = $m->t->copy; |
1663
|
|
|
|
|
|
|
$info = pdl(long, 0); |
1664
|
|
|
|
|
|
|
if(@dims == 3){ |
1665
|
|
|
|
|
|
|
$tau = zeroes($m->type, 2, ($dims[-2]-1)); |
1666
|
|
|
|
|
|
|
$m->cgehrd(1,$dims[-2],$tau,$info); |
1667
|
|
|
|
|
|
|
if (wantarray){ |
1668
|
|
|
|
|
|
|
$q = $m->copy; |
1669
|
|
|
|
|
|
|
$q->cunghr(1, $dims[-2], $tau, $info); |
1670
|
|
|
|
|
|
|
} |
1671
|
|
|
|
|
|
|
$m = $m->xchg(1,2); |
1672
|
|
|
|
|
|
|
$h = $m->mtri; |
1673
|
|
|
|
|
|
|
$h((0),:-2, 1:)->diagonal(0,1) .= $m((0),:-2, 1:)->diagonal(0,1); |
1674
|
|
|
|
|
|
|
$h((1),:-2, 1:)->diagonal(0,1) .= $m((1),:-2, 1:)->diagonal(0,1); |
1675
|
|
|
|
|
|
|
} |
1676
|
|
|
|
|
|
|
else{ |
1677
|
|
|
|
|
|
|
$tau = zeroes($m->type, ($dims[0]-1)); |
1678
|
|
|
|
|
|
|
$m->gehrd(1,$dims[0],$tau,$info); |
1679
|
|
|
|
|
|
|
if (wantarray){ |
1680
|
|
|
|
|
|
|
$q = $m->copy; |
1681
|
|
|
|
|
|
|
$q->orghr(1, $dims[0], $tau, $info); |
1682
|
|
|
|
|
|
|
} |
1683
|
|
|
|
|
|
|
$m = $m->xchg(0,1); |
1684
|
|
|
|
|
|
|
$h = $m->mtri; |
1685
|
|
|
|
|
|
|
$h(:-2, 1:)->diagonal(0,1) .= $m(:-2, 1:)->diagonal(0,1); |
1686
|
|
|
|
|
|
|
} |
1687
|
|
|
|
|
|
|
wantarray ? return ($h, $q->xchg(-2,-1)->sever) : $h; |
1688
|
|
|
|
|
|
|
} |
1689
|
|
|
|
|
|
|
|
1690
|
|
|
|
|
|
|
|
1691
|
|
|
|
|
|
|
=head2 mschur |
1692
|
|
|
|
|
|
|
|
1693
|
|
|
|
|
|
|
=for ref |
1694
|
|
|
|
|
|
|
|
1695
|
|
|
|
|
|
|
Computes Schur form, works inplace. |
1696
|
|
|
|
|
|
|
|
1697
|
|
|
|
|
|
|
A = Z x T x Z' |
1698
|
|
|
|
|
|
|
|
1699
|
|
|
|
|
|
|
Supports threading for unordered eigenvalues. |
1700
|
|
|
|
|
|
|
Uses L or L |
1701
|
|
|
|
|
|
|
from Lapack and returns schur(T) in scalar context. |
1702
|
|
|
|
|
|
|
Works on tranposed array(s). |
1703
|
|
|
|
|
|
|
|
1704
|
|
|
|
|
|
|
=for usage |
1705
|
|
|
|
|
|
|
|
1706
|
|
|
|
|
|
|
( PDL(schur), (PDL(eigenvalues), (PDL(left schur vectors), PDL(right schur vectors), $sdim), $info) ) = mschur(PDL(A), SCALAR(schur vector),SCALAR(left eigenvector), SCALAR(right eigenvector),SCALAR(select_func), SCALAR(backtransform), SCALAR(norm)) |
1707
|
|
|
|
|
|
|
schur vector : Schur vectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
1708
|
|
|
|
|
|
|
left eigenvector : Left eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
1709
|
|
|
|
|
|
|
right eigenvector : Right eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
1710
|
|
|
|
|
|
|
select_func : Select_func is used to select eigenvalues to sort |
1711
|
|
|
|
|
|
|
to the top left of the Schur form. |
1712
|
|
|
|
|
|
|
An eigenvalue is selected if PerlInt select_func(PDL::Complex(w)) is true; |
1713
|
|
|
|
|
|
|
Note that a selected complex eigenvalue may no longer |
1714
|
|
|
|
|
|
|
satisfy select_func(PDL::Complex(w)) = 1 after ordering, since |
1715
|
|
|
|
|
|
|
ordering may change the value of complex eigenvalues |
1716
|
|
|
|
|
|
|
(especially if the eigenvalue is ill-conditioned). |
1717
|
|
|
|
|
|
|
All eigenvalues/vectors are selected if select_func is undefined. |
1718
|
|
|
|
|
|
|
backtransform : Whether or not backtransforms eigenvectors to those of A. |
1719
|
|
|
|
|
|
|
Only supported if schur vectors are computed, default = 1. |
1720
|
|
|
|
|
|
|
norm : Whether or not computed eigenvectors are normalized to have Euclidean norm equal to |
1721
|
|
|
|
|
|
|
1 and largest component real, default = 1 |
1722
|
|
|
|
|
|
|
|
1723
|
|
|
|
|
|
|
Returned values : |
1724
|
|
|
|
|
|
|
Schur form T (SCALAR CONTEXT), |
1725
|
|
|
|
|
|
|
eigenvalues, |
1726
|
|
|
|
|
|
|
Schur vectors (Z) if requested, |
1727
|
|
|
|
|
|
|
left eigenvectors if requested |
1728
|
|
|
|
|
|
|
right eigenvectors if requested |
1729
|
|
|
|
|
|
|
sdim: Number of eigenvalues selected if select_func is defined. |
1730
|
|
|
|
|
|
|
info: Info output from gees/cgees. |
1731
|
|
|
|
|
|
|
|
1732
|
|
|
|
|
|
|
=for example |
1733
|
|
|
|
|
|
|
|
1734
|
|
|
|
|
|
|
my $a = random(10,10); |
1735
|
|
|
|
|
|
|
my $schur = mschur($a); |
1736
|
|
|
|
|
|
|
sub select{ |
1737
|
|
|
|
|
|
|
my $m = shift; |
1738
|
|
|
|
|
|
|
# select "discrete time" eigenspace |
1739
|
|
|
|
|
|
|
return $m->Cabs < 1 ? 1 : 0; |
1740
|
|
|
|
|
|
|
} |
1741
|
|
|
|
|
|
|
my ($schur,$eigen, $svectors,$evectors) = mschur($a,1,1,0,\&select); |
1742
|
|
|
|
|
|
|
|
1743
|
|
|
|
|
|
|
=cut |
1744
|
|
|
|
|
|
|
|
1745
|
|
|
|
|
|
|
|
1746
|
|
|
|
|
|
|
sub mschur{ |
1747
|
|
|
|
|
|
|
my $m = shift; |
1748
|
|
|
|
|
|
|
$m->mschur(@_); |
1749
|
|
|
|
|
|
|
|
1750
|
|
|
|
|
|
|
} |
1751
|
|
|
|
|
|
|
|
1752
|
|
|
|
|
|
|
sub PDL::mschur{ |
1753
|
|
|
|
|
|
|
my ($m, $jobv, $jobvl, $jobvr, $select_func, $mult,$norm) = @_; |
1754
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
1755
|
|
|
|
|
|
|
|
1756
|
|
|
|
|
|
|
barf("mschur: Require square array(s)") |
1757
|
|
|
|
|
|
|
unless($dims[0] == $dims[1]); |
1758
|
|
|
|
|
|
|
barf("mschur: thread doesn't supported for selected vectors") |
1759
|
|
|
|
|
|
|
if ($select_func && @dims > 2 && ($jobv == 2 || $jobvl == 2 || $jobvr == 2)); |
1760
|
|
|
|
|
|
|
|
1761
|
|
|
|
|
|
|
my ($w, $v, $info, $type, $select,$sdim, $vr,$vl, $mm, @ret, $select_f, $wi, $wtmp); |
1762
|
|
|
|
|
|
|
|
1763
|
|
|
|
|
|
|
$mult = 1 unless defined($mult); |
1764
|
|
|
|
|
|
|
$norm = 1 unless defined($norm); |
1765
|
|
|
|
|
|
|
$jobv = $jobvl = $jobvr = 0 unless wantarray; |
1766
|
|
|
|
|
|
|
$type = $m->type; |
1767
|
|
|
|
|
|
|
$select = $select_func ? pdl(long,1) : pdl(long,0); |
1768
|
|
|
|
|
|
|
|
1769
|
|
|
|
|
|
|
$info = null; |
1770
|
|
|
|
|
|
|
$sdim = null; |
1771
|
|
|
|
|
|
|
$wtmp = null; |
1772
|
|
|
|
|
|
|
$wi = null; |
1773
|
|
|
|
|
|
|
|
1774
|
|
|
|
|
|
|
$mm = $m->is_inplace ? $m->xchg(0,1) : $m->xchg(0,1)->copy; |
1775
|
|
|
|
|
|
|
if ($select_func){ |
1776
|
|
|
|
|
|
|
$select_f= sub{ |
1777
|
|
|
|
|
|
|
&$select_func(PDL::Complex::complex(pdl($type,@_[0..1]))); |
1778
|
|
|
|
|
|
|
}; |
1779
|
|
|
|
|
|
|
} |
1780
|
|
|
|
|
|
|
$v = $jobv ? PDL::new_from_specification('PDL', $type, $dims[1], $dims[1],@dims[2..$#dims]) : |
1781
|
|
|
|
|
|
|
pdl($type,0); |
1782
|
|
|
|
|
|
|
$mm->gees( $jobv, $select, $wtmp, $wi, $v, $sdim,$info, $select_f); |
1783
|
|
|
|
|
|
|
|
1784
|
|
|
|
|
|
|
if ($info->max > 0 && $_laerror){ |
1785
|
|
|
|
|
|
|
my ($index, @list); |
1786
|
|
|
|
|
|
|
$index = which((($info > 0)+($info <=$dims[0]))==2); |
1787
|
|
|
|
|
|
|
unless ($index->isempty){ |
1788
|
|
|
|
|
|
|
@list = $index->list; |
1789
|
|
|
|
|
|
|
laerror("mschur: The QR algorithm failed to converge for matrix (PDL(s) @list): \$info = $info"); |
1790
|
|
|
|
|
|
|
print ("Returning converged eigenvalues\n"); |
1791
|
|
|
|
|
|
|
} |
1792
|
|
|
|
|
|
|
if ($select_func){ |
1793
|
|
|
|
|
|
|
$index = which((($info > 0)+($info == ($dims[0]+1) ))==2); |
1794
|
|
|
|
|
|
|
unless ($index->isempty){ |
1795
|
|
|
|
|
|
|
@list = $index->list; |
1796
|
|
|
|
|
|
|
laerror("mschur: The eigenvalues could not be reordered because some\n". |
1797
|
|
|
|
|
|
|
"eigenvalues were too close to separate (the problem". |
1798
|
|
|
|
|
|
|
"is very ill-conditioned) for PDL(s) @list: \$info = $info"); |
1799
|
|
|
|
|
|
|
} |
1800
|
|
|
|
|
|
|
$index = which((($info > 0)+($info > ($dims[0]+1) ))==2); |
1801
|
|
|
|
|
|
|
unless ($index->isempty){ |
1802
|
|
|
|
|
|
|
@list = $index->list; |
1803
|
|
|
|
|
|
|
warn("mschur: The Schur form no longer satisfy select_func = 1\n because of roundoff". |
1804
|
|
|
|
|
|
|
"or underflow (PDL(s) @list)\n"); |
1805
|
|
|
|
|
|
|
} |
1806
|
|
|
|
|
|
|
} |
1807
|
|
|
|
|
|
|
} |
1808
|
|
|
|
|
|
|
if ($select_func){ |
1809
|
|
|
|
|
|
|
if ($jobvl == 2){ |
1810
|
|
|
|
|
|
|
if(!$sdim){ |
1811
|
|
|
|
|
|
|
push @ret, PDL::Complex->null; |
1812
|
|
|
|
|
|
|
$jobvl = 0; |
1813
|
|
|
|
|
|
|
} |
1814
|
|
|
|
|
|
|
} |
1815
|
|
|
|
|
|
|
if ($jobvr == 2){ |
1816
|
|
|
|
|
|
|
if(!$sdim){ |
1817
|
|
|
|
|
|
|
push @ret, PDL::Complex->null; |
1818
|
|
|
|
|
|
|
$jobvr = 0; |
1819
|
|
|
|
|
|
|
} |
1820
|
|
|
|
|
|
|
} |
1821
|
|
|
|
|
|
|
push @ret, $sdim; |
1822
|
|
|
|
|
|
|
} |
1823
|
|
|
|
|
|
|
if ($jobvl || $jobvr){ |
1824
|
|
|
|
|
|
|
my ($sel, $job, $wtmpi, $wtmpr, $sdims); |
1825
|
|
|
|
|
|
|
unless ($jobvr && $jobvl){ |
1826
|
|
|
|
|
|
|
$job = $jobvl ? 2 : 1; |
1827
|
|
|
|
|
|
|
} |
1828
|
|
|
|
|
|
|
if ($select_func){ |
1829
|
|
|
|
|
|
|
if ($jobvl == 1 || $jobvr == 1 || $mult){ |
1830
|
|
|
|
|
|
|
$sdims = null; |
1831
|
|
|
|
|
|
|
if ($jobv){ |
1832
|
|
|
|
|
|
|
$vr = $v->copy if $jobvr; |
1833
|
|
|
|
|
|
|
$vl = $v->copy if $jobvl; |
1834
|
|
|
|
|
|
|
} |
1835
|
|
|
|
|
|
|
else{ |
1836
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1],@dims[2..$#dims]) if $jobvr; |
1837
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1],@dims[2..$#dims]) if $jobvl; |
1838
|
|
|
|
|
|
|
$mult = 0; |
1839
|
|
|
|
|
|
|
} |
1840
|
|
|
|
|
|
|
$mm->trevc($job, $mult, $sel, $vl, $vr, $sdims, my $infos=null); |
1841
|
|
|
|
|
|
|
if ($jobvr){ |
1842
|
|
|
|
|
|
|
if($norm){ |
1843
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); |
1844
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
1845
|
|
|
|
|
|
|
unshift @ret, $jobvr == 2 ? $vr(,,:($sdim-1))->norm(1,1) : $vr->norm(1,1); |
1846
|
|
|
|
|
|
|
|
1847
|
|
|
|
|
|
|
} |
1848
|
|
|
|
|
|
|
else{ |
1849
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); |
1850
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
1851
|
|
|
|
|
|
|
unshift @ret, $jobvr == 2 ? $vr(,:($sdim-1))->sever : $vr; |
1852
|
|
|
|
|
|
|
} |
1853
|
|
|
|
|
|
|
} |
1854
|
|
|
|
|
|
|
if ($jobvl){ |
1855
|
|
|
|
|
|
|
if($norm){ |
1856
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); |
1857
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
1858
|
|
|
|
|
|
|
unshift @ret, $jobvl == 2 ? $vl(,,:($sdim-1))->norm(1,1) : $vl->norm(1,1); |
1859
|
|
|
|
|
|
|
} |
1860
|
|
|
|
|
|
|
else{ |
1861
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); |
1862
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
1863
|
|
|
|
|
|
|
unshift @ret, $jobvl == 2 ? $vl(,:($sdim-1))->sever : $vl; |
1864
|
|
|
|
|
|
|
} |
1865
|
|
|
|
|
|
|
} |
1866
|
|
|
|
|
|
|
} |
1867
|
|
|
|
|
|
|
else{ |
1868
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $dims[1], $sdim) if $jobvr; |
1869
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $dims[1], $sdim) if $jobvl; |
1870
|
|
|
|
|
|
|
$sel = zeroes($dims[1]); |
1871
|
|
|
|
|
|
|
$sel(:($sdim-1)) .= 1; |
1872
|
|
|
|
|
|
|
$mm->trevc($job, 2, $sel, $vl, $vr, $sdim, my $infos = null); |
1873
|
|
|
|
|
|
|
$wtmpr = $wtmp(:($sdim-1)); |
1874
|
|
|
|
|
|
|
$wtmpi = $wi(:($sdim-1)); |
1875
|
|
|
|
|
|
|
if ($jobvr){ |
1876
|
|
|
|
|
|
|
if ($norm){ |
1877
|
|
|
|
|
|
|
(undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr,1); |
1878
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
1879
|
|
|
|
|
|
|
unshift @ret, $vr->norm(1,1); |
1880
|
|
|
|
|
|
|
} |
1881
|
|
|
|
|
|
|
else{ |
1882
|
|
|
|
|
|
|
(undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr->xchg(0,1),0); |
1883
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
1884
|
|
|
|
|
|
|
unshift @ret,$vr; |
1885
|
|
|
|
|
|
|
} |
1886
|
|
|
|
|
|
|
} |
1887
|
|
|
|
|
|
|
if ($jobvl){ |
1888
|
|
|
|
|
|
|
if ($norm){ |
1889
|
|
|
|
|
|
|
(undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl,1); |
1890
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
1891
|
|
|
|
|
|
|
unshift @ret, $vl->norm(1,1); |
1892
|
|
|
|
|
|
|
|
1893
|
|
|
|
|
|
|
} |
1894
|
|
|
|
|
|
|
else{ |
1895
|
|
|
|
|
|
|
(undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl->xchg(0,1),0); |
1896
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
1897
|
|
|
|
|
|
|
unshift @ret, $vl; |
1898
|
|
|
|
|
|
|
} |
1899
|
|
|
|
|
|
|
} |
1900
|
|
|
|
|
|
|
} |
1901
|
|
|
|
|
|
|
} |
1902
|
|
|
|
|
|
|
else{ |
1903
|
|
|
|
|
|
|
if ($jobv){ |
1904
|
|
|
|
|
|
|
$vr = $v->copy if $jobvr; |
1905
|
|
|
|
|
|
|
$vl = $v->copy if $jobvl; |
1906
|
|
|
|
|
|
|
} |
1907
|
|
|
|
|
|
|
else{ |
1908
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1],@dims[2..$#dims]) if $jobvr; |
1909
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1],@dims[2..$#dims]) if $jobvl; |
1910
|
|
|
|
|
|
|
$mult = 0; |
1911
|
|
|
|
|
|
|
} |
1912
|
|
|
|
|
|
|
$mm->trevc($job, $mult, $sel, $vl, $vr, $sdim, my $infos=null); |
1913
|
|
|
|
|
|
|
if ($jobvr){ |
1914
|
|
|
|
|
|
|
if ($norm){ |
1915
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); |
1916
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
1917
|
|
|
|
|
|
|
unshift @ret, $vr->norm(1,1); |
1918
|
|
|
|
|
|
|
} |
1919
|
|
|
|
|
|
|
else{ |
1920
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); |
1921
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
1922
|
|
|
|
|
|
|
unshift @ret, $vr; |
1923
|
|
|
|
|
|
|
} |
1924
|
|
|
|
|
|
|
} |
1925
|
|
|
|
|
|
|
if ($jobvl){ |
1926
|
|
|
|
|
|
|
if ($norm){ |
1927
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); |
1928
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
1929
|
|
|
|
|
|
|
unshift @ret, $vl->norm(1,1); |
1930
|
|
|
|
|
|
|
} |
1931
|
|
|
|
|
|
|
else{ |
1932
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); |
1933
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
1934
|
|
|
|
|
|
|
unshift @ret, $vl; |
1935
|
|
|
|
|
|
|
} |
1936
|
|
|
|
|
|
|
} |
1937
|
|
|
|
|
|
|
} |
1938
|
|
|
|
|
|
|
} |
1939
|
|
|
|
|
|
|
$w = PDL::Complex::ecplx ($wtmp, $wi); |
1940
|
|
|
|
|
|
|
|
1941
|
|
|
|
|
|
|
if ($jobv == 2 && $select_func) { |
1942
|
|
|
|
|
|
|
$v = $sdim > 0 ? $v->xchg(0,1)->(:($sdim-1),)->sever : null; |
1943
|
|
|
|
|
|
|
unshift @ret,$v; |
1944
|
|
|
|
|
|
|
} |
1945
|
|
|
|
|
|
|
elsif($jobv){ |
1946
|
|
|
|
|
|
|
$v = $v->xchg(0,1)->sever; |
1947
|
|
|
|
|
|
|
unshift @ret,$v; |
1948
|
|
|
|
|
|
|
} |
1949
|
|
|
|
|
|
|
$m = $mm->xchg(0,1)->sever unless $m->is_inplace(0); |
1950
|
|
|
|
|
|
|
return wantarray ? ($m, $w, @ret, $info) : $m; |
1951
|
|
|
|
|
|
|
|
1952
|
|
|
|
|
|
|
} |
1953
|
|
|
|
|
|
|
|
1954
|
|
|
|
|
|
|
sub PDL::Complex::mschur { |
1955
|
|
|
|
|
|
|
my($m, $jobv, $jobvl, $jobvr, $select_func, $mult, $norm) = @_; |
1956
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
1957
|
|
|
|
|
|
|
|
1958
|
|
|
|
|
|
|
barf("mschur: Require square array(s)") |
1959
|
|
|
|
|
|
|
unless($dims[1] == $dims[2]); |
1960
|
|
|
|
|
|
|
barf("mschur: thread doesn't supported for selected vectors") |
1961
|
|
|
|
|
|
|
if ($select_func && @dims > 3 && ($jobv == 2 || $jobvl == 2 || $jobvr == 2)); |
1962
|
|
|
|
|
|
|
|
1963
|
|
|
|
|
|
|
my ($w, $v, $info, $type, $select,$sdim, $vr,$vl, $mm, @ret); |
1964
|
|
|
|
|
|
|
|
1965
|
|
|
|
|
|
|
$mult = 1 unless defined($mult); |
1966
|
|
|
|
|
|
|
$norm = 1 unless defined($norm); |
1967
|
|
|
|
|
|
|
$jobv = $jobvl = $jobvr = 0 unless wantarray; |
1968
|
|
|
|
|
|
|
$type = $m->type; |
1969
|
|
|
|
|
|
|
$select = $select_func ? pdl(long,1) : pdl(long,0); |
1970
|
|
|
|
|
|
|
|
1971
|
|
|
|
|
|
|
$info = null; |
1972
|
|
|
|
|
|
|
$sdim = null; |
1973
|
|
|
|
|
|
|
|
1974
|
|
|
|
|
|
|
$mm = $m->is_inplace ? $m->xchg(1,2) : $m->xchg(1,2)->copy; |
1975
|
|
|
|
|
|
|
$w = PDL::Complex->null; |
1976
|
|
|
|
|
|
|
$v = $jobv ? PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1],@dims[3..$#dims]) : |
1977
|
|
|
|
|
|
|
pdl($type,[0,0]); |
1978
|
|
|
|
|
|
|
|
1979
|
|
|
|
|
|
|
$mm->cgees( $jobv, $select, $w, $v, $sdim, $info, $select_func); |
1980
|
|
|
|
|
|
|
|
1981
|
|
|
|
|
|
|
if ($info->max > 0 && $_laerror){ |
1982
|
|
|
|
|
|
|
my ($index, @list); |
1983
|
|
|
|
|
|
|
$index = which((($info > 0)+($info <=$dims[1]))==2); |
1984
|
|
|
|
|
|
|
unless ($index->isempty){ |
1985
|
|
|
|
|
|
|
@list = $index->list; |
1986
|
|
|
|
|
|
|
laerror("mschur: The QR algorithm failed to converge for matrix (PDL(s) @list): \$info = $info"); |
1987
|
|
|
|
|
|
|
print ("Returning converged eigenvalues\n"); |
1988
|
|
|
|
|
|
|
} |
1989
|
|
|
|
|
|
|
if ($select_func){ |
1990
|
|
|
|
|
|
|
$index = which((($info > 0)+($info == ($dims[1]+1) ))==2); |
1991
|
|
|
|
|
|
|
unless ($index->isempty){ |
1992
|
|
|
|
|
|
|
@list = $index->list; |
1993
|
|
|
|
|
|
|
laerror("mschur: The eigenvalues could not be reordered because some\n". |
1994
|
|
|
|
|
|
|
"eigenvalues were too close to separate (the problem". |
1995
|
|
|
|
|
|
|
"is very ill-conditioned) for PDL(s) @list: \$info = $info"); |
1996
|
|
|
|
|
|
|
} |
1997
|
|
|
|
|
|
|
$index = which((($info > 0)+($info > ($dims[1]+1) ))==2); |
1998
|
|
|
|
|
|
|
unless ($index->isempty){ |
1999
|
|
|
|
|
|
|
@list = $index->list; |
2000
|
|
|
|
|
|
|
warn("mschur: The Schur form no longer satisfy select_func = 1\n because of roundoff". |
2001
|
|
|
|
|
|
|
"or underflow (PDL(s) @list)\n"); |
2002
|
|
|
|
|
|
|
} |
2003
|
|
|
|
|
|
|
} |
2004
|
|
|
|
|
|
|
} |
2005
|
|
|
|
|
|
|
|
2006
|
|
|
|
|
|
|
if ($select_func){ |
2007
|
|
|
|
|
|
|
if ($jobvl == 2){ |
2008
|
|
|
|
|
|
|
if (!$sdim){ |
2009
|
|
|
|
|
|
|
push @ret, PDL::Complex->null; |
2010
|
|
|
|
|
|
|
$jobvl = 0; |
2011
|
|
|
|
|
|
|
} |
2012
|
|
|
|
|
|
|
} |
2013
|
|
|
|
|
|
|
if ($jobvr == 2){ |
2014
|
|
|
|
|
|
|
if (!$sdim){ |
2015
|
|
|
|
|
|
|
push @ret, PDL::Complex->null; |
2016
|
|
|
|
|
|
|
$jobvr = 0; |
2017
|
|
|
|
|
|
|
} |
2018
|
|
|
|
|
|
|
} |
2019
|
|
|
|
|
|
|
push @ret, $sdim; |
2020
|
|
|
|
|
|
|
} |
2021
|
|
|
|
|
|
|
if ($jobvl || $jobvr){ |
2022
|
|
|
|
|
|
|
my ($sel, $job, $sdims); |
2023
|
|
|
|
|
|
|
unless ($jobvr && $jobvl){ |
2024
|
|
|
|
|
|
|
$job = $jobvl ? 2 : 1; |
2025
|
|
|
|
|
|
|
} |
2026
|
|
|
|
|
|
|
if ($select_func){ |
2027
|
|
|
|
|
|
|
if ($jobvl == 1 || $jobvr == 1 || $mult){ |
2028
|
|
|
|
|
|
|
$sdims = null; |
2029
|
|
|
|
|
|
|
if ($jobv){ |
2030
|
|
|
|
|
|
|
$vr = $v->copy if $jobvr; |
2031
|
|
|
|
|
|
|
$vl = $v->copy if $jobvl; |
2032
|
|
|
|
|
|
|
} |
2033
|
|
|
|
|
|
|
else{ |
2034
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1],@dims[3..$#dims]) if $jobvr; |
2035
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1],@dims[3..$#dims]) if $jobvl; |
2036
|
|
|
|
|
|
|
$mult = 0; |
2037
|
|
|
|
|
|
|
} |
2038
|
|
|
|
|
|
|
$mm->ctrevc($job, $mult, $sel, $vl, $vr, $sdims, my $infos=null); |
2039
|
|
|
|
|
|
|
if ($jobvr){ |
2040
|
|
|
|
|
|
|
if ($jobvr == 2){ |
2041
|
|
|
|
|
|
|
unshift @ret, $norm ? $vr(,,:($sdim-1))->norm(1,1) : |
2042
|
|
|
|
|
|
|
$vr(,,:($sdim-1))->xchg(1,2)->sever; |
2043
|
|
|
|
|
|
|
} |
2044
|
|
|
|
|
|
|
else{ |
2045
|
|
|
|
|
|
|
unshift @ret, $norm ? $vr->norm(1,1) : $vr->xchg(1,2)->sever; |
2046
|
|
|
|
|
|
|
} |
2047
|
|
|
|
|
|
|
} |
2048
|
|
|
|
|
|
|
if ($jobvl){ |
2049
|
|
|
|
|
|
|
if ($jobvl == 2){ |
2050
|
|
|
|
|
|
|
unshift @ret, $norm ? $vl(,,:($sdim-1))->norm(1,1) : |
2051
|
|
|
|
|
|
|
$vl(,,:($sdim-1))->xchg(1,2)->sever; |
2052
|
|
|
|
|
|
|
} |
2053
|
|
|
|
|
|
|
else{ |
2054
|
|
|
|
|
|
|
unshift @ret, $norm ? $vl->norm(1,1) : $vl->xchg(1,2)->sever; |
2055
|
|
|
|
|
|
|
} |
2056
|
|
|
|
|
|
|
} |
2057
|
|
|
|
|
|
|
} |
2058
|
|
|
|
|
|
|
else{ |
2059
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2,$dims[1], $sdim) if $jobvr; |
2060
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $sdim) if $jobvl; |
2061
|
|
|
|
|
|
|
$sel = zeroes($dims[1]); |
2062
|
|
|
|
|
|
|
$sel(:($sdim-1)) .= 1; |
2063
|
|
|
|
|
|
|
$mm->ctrevc($job, 2, $sel, $vl, $vr, $sdim, my $infos=null); |
2064
|
|
|
|
|
|
|
if ($jobvr){ |
2065
|
|
|
|
|
|
|
unshift @ret, $norm ? $vr->norm(1,1) : $vr->xchg(1,2)->sever; |
2066
|
|
|
|
|
|
|
} |
2067
|
|
|
|
|
|
|
if ($jobvl){ |
2068
|
|
|
|
|
|
|
unshift @ret, $norm ? $vl->norm(1,1) : $vl->xchg(1,2)->sever; |
2069
|
|
|
|
|
|
|
} |
2070
|
|
|
|
|
|
|
} |
2071
|
|
|
|
|
|
|
} |
2072
|
|
|
|
|
|
|
else{ |
2073
|
|
|
|
|
|
|
if ($jobv){ |
2074
|
|
|
|
|
|
|
$vr = $v->copy if $jobvr; |
2075
|
|
|
|
|
|
|
$vl = $v->copy if $jobvl; |
2076
|
|
|
|
|
|
|
} |
2077
|
|
|
|
|
|
|
else{ |
2078
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1],@dims[3..$#dims]) if $jobvr; |
2079
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1],@dims[3..$#dims]) if $jobvl; |
2080
|
|
|
|
|
|
|
$mult = 0; |
2081
|
|
|
|
|
|
|
} |
2082
|
|
|
|
|
|
|
$mm->ctrevc($job, $mult, $sel, $vl, $vr, $sdim, my $infos=null); |
2083
|
|
|
|
|
|
|
if ($jobvl){ |
2084
|
|
|
|
|
|
|
push @ret, $norm ? $vl->norm(1,1) : $vl->xchg(1,2)->sever; |
2085
|
|
|
|
|
|
|
} |
2086
|
|
|
|
|
|
|
if ($jobvr){ |
2087
|
|
|
|
|
|
|
push @ret, $norm ? $vr->norm(1,1) : $vr->xchg(1,2)->sever; |
2088
|
|
|
|
|
|
|
} |
2089
|
|
|
|
|
|
|
} |
2090
|
|
|
|
|
|
|
} |
2091
|
|
|
|
|
|
|
if ($jobv == 2 && $select_func) { |
2092
|
|
|
|
|
|
|
$v = $sdim > 0 ? $v->xchg(1,2)->(,:($sdim-1),) ->sever : PDL::Complex->null; |
2093
|
|
|
|
|
|
|
unshift @ret,$v; |
2094
|
|
|
|
|
|
|
} |
2095
|
|
|
|
|
|
|
elsif($jobv){ |
2096
|
|
|
|
|
|
|
$v = $v->xchg(1,2)->sever; |
2097
|
|
|
|
|
|
|
unshift @ret,$v; |
2098
|
|
|
|
|
|
|
} |
2099
|
|
|
|
|
|
|
$m = $mm->xchg(1,2)->sever unless $m->is_inplace(0); |
2100
|
|
|
|
|
|
|
return wantarray ? ($m, $w, @ret, $info) : $m; |
2101
|
|
|
|
|
|
|
|
2102
|
|
|
|
|
|
|
} |
2103
|
|
|
|
|
|
|
|
2104
|
|
|
|
|
|
|
|
2105
|
|
|
|
|
|
|
|
2106
|
|
|
|
|
|
|
=head2 mschurx |
2107
|
|
|
|
|
|
|
|
2108
|
|
|
|
|
|
|
=for ref |
2109
|
|
|
|
|
|
|
|
2110
|
|
|
|
|
|
|
Computes Schur form, works inplace. |
2111
|
|
|
|
|
|
|
Uses L or L |
2112
|
|
|
|
|
|
|
from Lapack and returns schur(T) in scalar context. |
2113
|
|
|
|
|
|
|
Works on transposed array. |
2114
|
|
|
|
|
|
|
|
2115
|
|
|
|
|
|
|
=for usage |
2116
|
|
|
|
|
|
|
|
2117
|
|
|
|
|
|
|
( PDL(schur) (,PDL(eigenvalues)) (, PDL(schur vectors), HASH(result)) ) = mschurx(PDL, SCALAR(schur vector), SCALAR(left eigenvector), SCALAR(right eigenvector),SCALAR(select_func), SCALAR(sense), SCALAR(backtransform), SCALAR(norm)) |
2118
|
|
|
|
|
|
|
schur vector : Schur vectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
2119
|
|
|
|
|
|
|
left eigenvector : Left eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
2120
|
|
|
|
|
|
|
right eigenvector : Right eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
2121
|
|
|
|
|
|
|
select_func : Select_func is used to select eigenvalues to sort |
2122
|
|
|
|
|
|
|
to the top left of the Schur form. |
2123
|
|
|
|
|
|
|
An eigenvalue is selected if PerlInt select_func(PDL::Complex(w)) is true; |
2124
|
|
|
|
|
|
|
Note that a selected complex eigenvalue may no longer |
2125
|
|
|
|
|
|
|
satisfy select_func(PDL::Complex(w)) = 1 after ordering, since |
2126
|
|
|
|
|
|
|
ordering may change the value of complex eigenvalues |
2127
|
|
|
|
|
|
|
(especially if the eigenvalue is ill-conditioned). |
2128
|
|
|
|
|
|
|
All eigenvalues/vectors are selected if select_func is undefined. |
2129
|
|
|
|
|
|
|
sense : Determines which reciprocal condition numbers will be computed. |
2130
|
|
|
|
|
|
|
0: None are computed |
2131
|
|
|
|
|
|
|
1: Computed for average of selected eigenvalues only |
2132
|
|
|
|
|
|
|
2: Computed for selected right invariant subspace only |
2133
|
|
|
|
|
|
|
3: Computed for both |
2134
|
|
|
|
|
|
|
If select_func is undefined, sense is not used. |
2135
|
|
|
|
|
|
|
backtransform : Whether or not backtransforms eigenvectors to those of A. |
2136
|
|
|
|
|
|
|
Only supported if schur vector are computed, default = 1 |
2137
|
|
|
|
|
|
|
norm : Whether or not computed eigenvectors are normalized to have Euclidean norm equal to |
2138
|
|
|
|
|
|
|
1 and largest component real, default = 1 |
2139
|
|
|
|
|
|
|
|
2140
|
|
|
|
|
|
|
Returned values : |
2141
|
|
|
|
|
|
|
Schur form T (SCALAR CONTEXT), |
2142
|
|
|
|
|
|
|
eigenvalues, |
2143
|
|
|
|
|
|
|
Schur vectors if requested, |
2144
|
|
|
|
|
|
|
HASH{VL}: left eigenvectors if requested |
2145
|
|
|
|
|
|
|
HASH{VR}: right eigenvectors if requested |
2146
|
|
|
|
|
|
|
HASH{info}: info output from gees/cgees. |
2147
|
|
|
|
|
|
|
if select_func is defined: |
2148
|
|
|
|
|
|
|
HASH{n}: number of eigenvalues selected, |
2149
|
|
|
|
|
|
|
HASH{rconde}: reciprocal condition numbers for the average of |
2150
|
|
|
|
|
|
|
the selected eigenvalues if requested, |
2151
|
|
|
|
|
|
|
HASH{rcondv}: reciprocal condition numbers for the selected |
2152
|
|
|
|
|
|
|
right invariant subspace if requested. |
2153
|
|
|
|
|
|
|
|
2154
|
|
|
|
|
|
|
=for example |
2155
|
|
|
|
|
|
|
|
2156
|
|
|
|
|
|
|
my $a = random(10,10); |
2157
|
|
|
|
|
|
|
my $schur = mschurx($a); |
2158
|
|
|
|
|
|
|
sub select{ |
2159
|
|
|
|
|
|
|
my $m = shift; |
2160
|
|
|
|
|
|
|
# select "discrete time" eigenspace |
2161
|
|
|
|
|
|
|
return $m->Cabs < 1 ? 1 : 0; |
2162
|
|
|
|
|
|
|
} |
2163
|
|
|
|
|
|
|
my ($schur,$eigen, $vectors,%ret) = mschurx($a,1,0,0,\&select); |
2164
|
|
|
|
|
|
|
|
2165
|
|
|
|
|
|
|
=cut |
2166
|
|
|
|
|
|
|
|
2167
|
|
|
|
|
|
|
|
2168
|
|
|
|
|
|
|
*mschurx = \&PDL::mschurx; |
2169
|
|
|
|
|
|
|
|
2170
|
|
|
|
|
|
|
sub PDL::mschurx{ |
2171
|
|
|
|
|
|
|
my($m, $jobv, $jobvl, $jobvr, $select_func, $sense, $mult,$norm) = @_; |
2172
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
2173
|
|
|
|
|
|
|
|
2174
|
|
|
|
|
|
|
barf("mschur: Require a square matrix") |
2175
|
|
|
|
|
|
|
unless( ( (@dims == 2)|| (@dims == 3) )&& $dims[-1] == $dims[-2]); |
2176
|
|
|
|
|
|
|
|
2177
|
|
|
|
|
|
|
my ($w, $v, $info, $type, $select, $sdim, $rconde, $rcondv, %ret, $mm, $vl, $vr); |
2178
|
|
|
|
|
|
|
|
2179
|
|
|
|
|
|
|
$mult = 1 unless defined($mult); |
2180
|
|
|
|
|
|
|
$norm = 1 unless defined($norm); |
2181
|
|
|
|
|
|
|
$jobv = $jobvl = $jobvr = 0 unless wantarray; |
2182
|
|
|
|
|
|
|
$type = $m->type; |
2183
|
|
|
|
|
|
|
if ($select_func){ |
2184
|
|
|
|
|
|
|
$select = pdl(long 1); |
2185
|
|
|
|
|
|
|
} |
2186
|
|
|
|
|
|
|
else{ |
2187
|
|
|
|
|
|
|
$select = pdl(long,0); |
2188
|
|
|
|
|
|
|
$sense = pdl(long,0); |
2189
|
|
|
|
|
|
|
} |
2190
|
|
|
|
|
|
|
|
2191
|
|
|
|
|
|
|
$info = null; |
2192
|
|
|
|
|
|
|
$sdim = null; |
2193
|
|
|
|
|
|
|
$rconde = null; |
2194
|
|
|
|
|
|
|
$rcondv = null; |
2195
|
|
|
|
|
|
|
$mm = $m->is_inplace ? $m->xchg(-1,-2) : $m->xchg(-1,-2)->copy; |
2196
|
|
|
|
|
|
|
|
2197
|
|
|
|
|
|
|
if (@dims == 3){ |
2198
|
|
|
|
|
|
|
$w = PDL::Complex->null; |
2199
|
|
|
|
|
|
|
$v = $jobv ? PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]) : |
2200
|
|
|
|
|
|
|
pdl($type,[0,0]); |
2201
|
|
|
|
|
|
|
$mm->cgeesx( $jobv, $select, $sense, $w, $v, $sdim, $rconde, $rcondv,$info, $select_func); |
2202
|
|
|
|
|
|
|
|
2203
|
|
|
|
|
|
|
if ($info){ |
2204
|
|
|
|
|
|
|
if ($info < $dims[1]){ |
2205
|
|
|
|
|
|
|
laerror("mschurx: The QR algorithm failed to converge"); |
2206
|
|
|
|
|
|
|
print ("Returning converged eigenvalues\n") if $_laerror; |
2207
|
|
|
|
|
|
|
} |
2208
|
|
|
|
|
|
|
laerror("mschurx: The eigenvalues could not be reordered because some\n". |
2209
|
|
|
|
|
|
|
"eigenvalues were too close to separate (the problem". |
2210
|
|
|
|
|
|
|
"is very ill-conditioned)") |
2211
|
|
|
|
|
|
|
if $info == ($dims[1] + 1); |
2212
|
|
|
|
|
|
|
warn("mschurx: The Schur form no longer satisfy select_func = 1\n because of roundoff or underflow\n") |
2213
|
|
|
|
|
|
|
if ($info > ($dims[1] + 1) and $_laerror); |
2214
|
|
|
|
|
|
|
} |
2215
|
|
|
|
|
|
|
|
2216
|
|
|
|
|
|
|
if ($select_func){ |
2217
|
|
|
|
|
|
|
if(!$sdim){ |
2218
|
|
|
|
|
|
|
if ($jobvl == 2){ |
2219
|
|
|
|
|
|
|
$ret{VL} = PDL::Complex->null; |
2220
|
|
|
|
|
|
|
$jobvl = 0; |
2221
|
|
|
|
|
|
|
} |
2222
|
|
|
|
|
|
|
if ($jobvr == 2){ |
2223
|
|
|
|
|
|
|
$ret{VR} = PDL::Complex->null; |
2224
|
|
|
|
|
|
|
$jobvr = 0; |
2225
|
|
|
|
|
|
|
} |
2226
|
|
|
|
|
|
|
} |
2227
|
|
|
|
|
|
|
$ret{n} = $sdim; |
2228
|
|
|
|
|
|
|
} |
2229
|
|
|
|
|
|
|
if ($jobvl || $jobvr){ |
2230
|
|
|
|
|
|
|
my ($sel, $job, $sdims); |
2231
|
|
|
|
|
|
|
unless ($jobvr && $jobvl){ |
2232
|
|
|
|
|
|
|
$job = $jobvl ? 2 : 1; |
2233
|
|
|
|
|
|
|
} |
2234
|
|
|
|
|
|
|
if ($select_func){ |
2235
|
|
|
|
|
|
|
if ($jobvl == 1 || $jobvr == 1 || $mult){ |
2236
|
|
|
|
|
|
|
$sdims = null; |
2237
|
|
|
|
|
|
|
if ($jobv){ |
2238
|
|
|
|
|
|
|
$vr = $v->copy if $jobvr; |
2239
|
|
|
|
|
|
|
$vl = $v->copy if $jobvl; |
2240
|
|
|
|
|
|
|
} |
2241
|
|
|
|
|
|
|
else{ |
2242
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]) if $jobvr; |
2243
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]) if $jobvl; |
2244
|
|
|
|
|
|
|
$mult = 0; |
2245
|
|
|
|
|
|
|
} |
2246
|
|
|
|
|
|
|
$mm->ctrevc($job, $mult, $sel, $vl, $vr, $sdims, my $infos=null); |
2247
|
|
|
|
|
|
|
if ($jobvr){ |
2248
|
|
|
|
|
|
|
if ($jobvr == 2){ |
2249
|
|
|
|
|
|
|
$ret{VR} = $norm ? $vr(,,:($sdim-1))->norm(1,1) : |
2250
|
|
|
|
|
|
|
$vr(,,:($sdim-1))->xchg(1,2)->sever; |
2251
|
|
|
|
|
|
|
} |
2252
|
|
|
|
|
|
|
else{ |
2253
|
|
|
|
|
|
|
$ret{VR} = $norm ? $vr->norm(1,1) : $vr->xchg(1,2)->sever; |
2254
|
|
|
|
|
|
|
} |
2255
|
|
|
|
|
|
|
} |
2256
|
|
|
|
|
|
|
if ($jobvl){ |
2257
|
|
|
|
|
|
|
if ($jobvl == 2){ |
2258
|
|
|
|
|
|
|
$ret{VL} = $norm ? $vl(,,:($sdim-1))->norm(1,1) : |
2259
|
|
|
|
|
|
|
$vl(,,:($sdim-1))->xchg(1,2)->sever; |
2260
|
|
|
|
|
|
|
} |
2261
|
|
|
|
|
|
|
else{ |
2262
|
|
|
|
|
|
|
$ret{VL} = $norm ? $vl->norm(1,1) : $vl->xchg(1,2)->sever; |
2263
|
|
|
|
|
|
|
} |
2264
|
|
|
|
|
|
|
} |
2265
|
|
|
|
|
|
|
} |
2266
|
|
|
|
|
|
|
else{ |
2267
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2,$dims[1], $sdim) if $jobvr; |
2268
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $sdim) if $jobvl; |
2269
|
|
|
|
|
|
|
$sel = zeroes($dims[1]); |
2270
|
|
|
|
|
|
|
$sel(:($sdim-1)) .= 1; |
2271
|
|
|
|
|
|
|
$mm->ctrevc($job, 2, $sel, $vl, $vr, $sdim, my $infos=null); |
2272
|
|
|
|
|
|
|
if ($jobvr){ |
2273
|
|
|
|
|
|
|
$ret{VL} = $norm ? $vr->norm(1,1) : $vr->xchg(1,2)->sever; |
2274
|
|
|
|
|
|
|
} |
2275
|
|
|
|
|
|
|
if ($jobvl){ |
2276
|
|
|
|
|
|
|
$ret{VL} = $norm ? $vl->norm(1,1) : $vl->xchg(1,2)->sever; |
2277
|
|
|
|
|
|
|
} |
2278
|
|
|
|
|
|
|
} |
2279
|
|
|
|
|
|
|
} |
2280
|
|
|
|
|
|
|
else{ |
2281
|
|
|
|
|
|
|
if ($jobv){ |
2282
|
|
|
|
|
|
|
$vr = $v->copy if $jobvr; |
2283
|
|
|
|
|
|
|
$vl = $v->copy if $jobvl; |
2284
|
|
|
|
|
|
|
} |
2285
|
|
|
|
|
|
|
else{ |
2286
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]) if $jobvr; |
2287
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, $dims[1], 2, $dims[1]) if $jobvl; |
2288
|
|
|
|
|
|
|
$mult = 0; |
2289
|
|
|
|
|
|
|
} |
2290
|
|
|
|
|
|
|
$mm->ctrevc($job, $mult, $sel, $vl, $vr, $sdim, my $infos=null); |
2291
|
|
|
|
|
|
|
if ($jobvl){ |
2292
|
|
|
|
|
|
|
$ret{VL} = $norm ? $vl->norm(1,1) : $vl->xchg(1,2)->sever; |
2293
|
|
|
|
|
|
|
} |
2294
|
|
|
|
|
|
|
if ($jobvr){ |
2295
|
|
|
|
|
|
|
$ret{VR} = $norm ? $vr->norm(1,1) : $vr->xchg(1,2)->sever; |
2296
|
|
|
|
|
|
|
} |
2297
|
|
|
|
|
|
|
} |
2298
|
|
|
|
|
|
|
} |
2299
|
|
|
|
|
|
|
if ($jobv == 2 && $select_func) { |
2300
|
|
|
|
|
|
|
$v = $sdim > 0 ? $v->xchg(1,2)->(,:($sdim-1),) ->sever : PDL::Complex->null; |
2301
|
|
|
|
|
|
|
} |
2302
|
|
|
|
|
|
|
elsif($jobv){ |
2303
|
|
|
|
|
|
|
$v = $v->xchg(1,2)->sever; |
2304
|
|
|
|
|
|
|
} |
2305
|
|
|
|
|
|
|
|
2306
|
|
|
|
|
|
|
} |
2307
|
|
|
|
|
|
|
else{ |
2308
|
|
|
|
|
|
|
my ($select_f, $wi, $wtmp); |
2309
|
|
|
|
|
|
|
if ($select_func){ |
2310
|
|
|
|
|
|
|
no strict 'refs'; |
2311
|
|
|
|
|
|
|
$select_f= sub{ |
2312
|
|
|
|
|
|
|
&$select_func(PDL::Complex::complex(pdl($type,$_[0],$_[1]))); |
2313
|
|
|
|
|
|
|
}; |
2314
|
|
|
|
|
|
|
} |
2315
|
|
|
|
|
|
|
$wi = null; |
2316
|
|
|
|
|
|
|
$wtmp = null; |
2317
|
|
|
|
|
|
|
$v = $jobv ? PDL::new_from_specification('PDL', $type, $dims[1], $dims[1]) : |
2318
|
|
|
|
|
|
|
pdl($type,0); |
2319
|
|
|
|
|
|
|
$mm->geesx( $jobv, $select, $sense, $wtmp, $wi, $v, $sdim, $rconde, $rcondv,$info, $select_f); |
2320
|
|
|
|
|
|
|
if ($info){ |
2321
|
|
|
|
|
|
|
if ($info < $dims[0]){ |
2322
|
|
|
|
|
|
|
laerror("mschurx: The QR algorithm failed to converge"); |
2323
|
|
|
|
|
|
|
print ("Returning converged eigenvalues\n") if $_laerror; |
2324
|
|
|
|
|
|
|
} |
2325
|
|
|
|
|
|
|
laerror("mschurx: The eigenvalues could not be reordered because some\n". |
2326
|
|
|
|
|
|
|
"eigenvalues were too close to separate (the problem". |
2327
|
|
|
|
|
|
|
"is very ill-conditioned)") |
2328
|
|
|
|
|
|
|
if $info == ($dims[0] + 1); |
2329
|
|
|
|
|
|
|
warn("mschurx: The Schur form no longer satisfy select_func = 1\n because of roundoff or underflow\n") |
2330
|
|
|
|
|
|
|
if ($info > ($dims[0] + 1) and $_laerror); |
2331
|
|
|
|
|
|
|
} |
2332
|
|
|
|
|
|
|
|
2333
|
|
|
|
|
|
|
if ($select_func){ |
2334
|
|
|
|
|
|
|
if(!$sdim){ |
2335
|
|
|
|
|
|
|
if ($jobvl == 2){ |
2336
|
|
|
|
|
|
|
$ret{VL} = null; |
2337
|
|
|
|
|
|
|
$jobvl = 0; |
2338
|
|
|
|
|
|
|
} |
2339
|
|
|
|
|
|
|
if ($jobvr == 2){ |
2340
|
|
|
|
|
|
|
$ret{VR} = null; |
2341
|
|
|
|
|
|
|
$jobvr = 0; |
2342
|
|
|
|
|
|
|
} |
2343
|
|
|
|
|
|
|
} |
2344
|
|
|
|
|
|
|
$ret{n} = $sdim; |
2345
|
|
|
|
|
|
|
} |
2346
|
|
|
|
|
|
|
if ($jobvl || $jobvr){ |
2347
|
|
|
|
|
|
|
my ($sel, $job, $wtmpi, $wtmpr, $sdims); |
2348
|
|
|
|
|
|
|
unless ($jobvr && $jobvl){ |
2349
|
|
|
|
|
|
|
$job = $jobvl ? 2 : 1; |
2350
|
|
|
|
|
|
|
} |
2351
|
|
|
|
|
|
|
if ($select_func){ |
2352
|
|
|
|
|
|
|
if ($jobvl == 1 || $jobvr == 1 || $mult){ |
2353
|
|
|
|
|
|
|
$sdims = null; |
2354
|
|
|
|
|
|
|
if ($jobv){ |
2355
|
|
|
|
|
|
|
$vr = $v->copy if $jobvr; |
2356
|
|
|
|
|
|
|
$vl = $v->copy if $jobvl; |
2357
|
|
|
|
|
|
|
} |
2358
|
|
|
|
|
|
|
else{ |
2359
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1]) if $jobvr; |
2360
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1]) if $jobvl; |
2361
|
|
|
|
|
|
|
$mult = 0; |
2362
|
|
|
|
|
|
|
} |
2363
|
|
|
|
|
|
|
$mm->trevc($job, $mult, $sel, $vl, $vr, $sdims, my $infos=null); |
2364
|
|
|
|
|
|
|
|
2365
|
|
|
|
|
|
|
if ($jobvr){ |
2366
|
|
|
|
|
|
|
if($norm){ |
2367
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); |
2368
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
2369
|
|
|
|
|
|
|
$ret{VR} = $jobvr == 2 ? $vr(,,:($sdim-1))->norm(1,1) : $vr->norm(1,1); |
2370
|
|
|
|
|
|
|
} |
2371
|
|
|
|
|
|
|
else{ |
2372
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); |
2373
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
2374
|
|
|
|
|
|
|
$ret{VR} = $jobvr == 2 ? $vr(,:($sdim-1))->sever : $vr; |
2375
|
|
|
|
|
|
|
} |
2376
|
|
|
|
|
|
|
} |
2377
|
|
|
|
|
|
|
if ($jobvl){ |
2378
|
|
|
|
|
|
|
if($norm){ |
2379
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); |
2380
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
2381
|
|
|
|
|
|
|
$ret{VL}= $jobvl == 2 ? $vl(,,:($sdim-1))->norm(1,1) : $vl->norm(1,1); |
2382
|
|
|
|
|
|
|
} |
2383
|
|
|
|
|
|
|
else{ |
2384
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); |
2385
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
2386
|
|
|
|
|
|
|
$ret{VL}= $jobvl == 2 ? $vl(,:($sdim-1))->sever : $vl; |
2387
|
|
|
|
|
|
|
} |
2388
|
|
|
|
|
|
|
} |
2389
|
|
|
|
|
|
|
} |
2390
|
|
|
|
|
|
|
else{ |
2391
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $dims[1], $sdim) if $jobvr; |
2392
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $dims[1], $sdim) if $jobvl; |
2393
|
|
|
|
|
|
|
$sel = zeroes($dims[1]); |
2394
|
|
|
|
|
|
|
$sel(:($sdim-1)) .= 1; |
2395
|
|
|
|
|
|
|
$mm->trevc($job, 2, $sel, $vl, $vr, $sdim, my $infos = null); |
2396
|
|
|
|
|
|
|
$wtmpr = $wtmp(:($sdim-1)); |
2397
|
|
|
|
|
|
|
$wtmpi = $wi(:($sdim-1)); |
2398
|
|
|
|
|
|
|
|
2399
|
|
|
|
|
|
|
if ($jobvr){ |
2400
|
|
|
|
|
|
|
if ($norm){ |
2401
|
|
|
|
|
|
|
(undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr,1); |
2402
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
2403
|
|
|
|
|
|
|
$ret{VR} = $vr->norm(1,1); |
2404
|
|
|
|
|
|
|
} |
2405
|
|
|
|
|
|
|
else{ |
2406
|
|
|
|
|
|
|
(undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr->xchg(0,1),0); |
2407
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
2408
|
|
|
|
|
|
|
$ret{VR} = $vr; |
2409
|
|
|
|
|
|
|
} |
2410
|
|
|
|
|
|
|
} |
2411
|
|
|
|
|
|
|
if ($jobvl){ |
2412
|
|
|
|
|
|
|
if ($norm){ |
2413
|
|
|
|
|
|
|
(undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl,1); |
2414
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
2415
|
|
|
|
|
|
|
$ret{VL} = $vl->norm(1,1); |
2416
|
|
|
|
|
|
|
} |
2417
|
|
|
|
|
|
|
else{ |
2418
|
|
|
|
|
|
|
(undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl->xchg(0,1),0); |
2419
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
2420
|
|
|
|
|
|
|
$ret{VL} = $vl; |
2421
|
|
|
|
|
|
|
} |
2422
|
|
|
|
|
|
|
} |
2423
|
|
|
|
|
|
|
} |
2424
|
|
|
|
|
|
|
} |
2425
|
|
|
|
|
|
|
else{ |
2426
|
|
|
|
|
|
|
if ($jobv){ |
2427
|
|
|
|
|
|
|
$vr = $v->copy if $jobvr; |
2428
|
|
|
|
|
|
|
$vl = $v->copy if $jobvl; |
2429
|
|
|
|
|
|
|
} |
2430
|
|
|
|
|
|
|
else{ |
2431
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1]) if $jobvr; |
2432
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $dims[1], $dims[1]) if $jobvl; |
2433
|
|
|
|
|
|
|
$mult = 0; |
2434
|
|
|
|
|
|
|
} |
2435
|
|
|
|
|
|
|
$mm->trevc($job, $mult, $sel, $vl, $vr, $sdim, my $infos=null); |
2436
|
|
|
|
|
|
|
if ($jobvr){ |
2437
|
|
|
|
|
|
|
if ($norm){ |
2438
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); |
2439
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
2440
|
|
|
|
|
|
|
$ret{VR} = $vr->norm(1,1); |
2441
|
|
|
|
|
|
|
} |
2442
|
|
|
|
|
|
|
else{ |
2443
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); |
2444
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
2445
|
|
|
|
|
|
|
$ret{VR} = $vr; |
2446
|
|
|
|
|
|
|
} |
2447
|
|
|
|
|
|
|
} |
2448
|
|
|
|
|
|
|
if ($jobvl){ |
2449
|
|
|
|
|
|
|
if ($norm){ |
2450
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); |
2451
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
2452
|
|
|
|
|
|
|
$ret{VL} = $vl->norm(1,1); |
2453
|
|
|
|
|
|
|
} |
2454
|
|
|
|
|
|
|
else{ |
2455
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); |
2456
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
2457
|
|
|
|
|
|
|
$ret{VL} = $vl; |
2458
|
|
|
|
|
|
|
} |
2459
|
|
|
|
|
|
|
} |
2460
|
|
|
|
|
|
|
} |
2461
|
|
|
|
|
|
|
} |
2462
|
|
|
|
|
|
|
$w = PDL::Complex::ecplx ($wtmp, $wi); |
2463
|
|
|
|
|
|
|
|
2464
|
|
|
|
|
|
|
if ($jobv == 2 && $select_func) { |
2465
|
|
|
|
|
|
|
$v = $sdim > 0 ? $v->xchg(0,1)->(:($sdim-1),) ->sever : null; |
2466
|
|
|
|
|
|
|
} |
2467
|
|
|
|
|
|
|
elsif($jobv){ |
2468
|
|
|
|
|
|
|
$v = $v->xchg(0,1)->sever; |
2469
|
|
|
|
|
|
|
} |
2470
|
|
|
|
|
|
|
|
2471
|
|
|
|
|
|
|
} |
2472
|
|
|
|
|
|
|
|
2473
|
|
|
|
|
|
|
|
2474
|
|
|
|
|
|
|
$ret{info} = $info; |
2475
|
|
|
|
|
|
|
if ($sense){ |
2476
|
|
|
|
|
|
|
if ($sense == 3){ |
2477
|
|
|
|
|
|
|
$ret{rconde} = $rconde; |
2478
|
|
|
|
|
|
|
$ret{rcondv} = $rcondv; |
2479
|
|
|
|
|
|
|
} |
2480
|
|
|
|
|
|
|
else{ |
2481
|
|
|
|
|
|
|
$ret{rconde} = $rconde if ($sense == 1); |
2482
|
|
|
|
|
|
|
$ret{rcondv} = $rcondv if ($sense == 2); |
2483
|
|
|
|
|
|
|
} |
2484
|
|
|
|
|
|
|
} |
2485
|
|
|
|
|
|
|
$m = $mm->xchg(-1,-2)->sever unless $m->is_inplace(0); |
2486
|
|
|
|
|
|
|
return wantarray ? $jobv ? ($m, $w, $v, %ret) : |
2487
|
|
|
|
|
|
|
($m, $w, %ret) : |
2488
|
|
|
|
|
|
|
$m; |
2489
|
|
|
|
|
|
|
} |
2490
|
|
|
|
|
|
|
|
2491
|
|
|
|
|
|
|
|
2492
|
|
|
|
|
|
|
# scale by max(abs(real)+abs(imag)) |
2493
|
|
|
|
|
|
|
sub magn_norm{ |
2494
|
|
|
|
|
|
|
my ($m, $trans) = @_; |
2495
|
|
|
|
|
|
|
|
2496
|
|
|
|
|
|
|
# If trans == true => transpose output matrice |
2497
|
|
|
|
|
|
|
|
2498
|
|
|
|
|
|
|
|
2499
|
|
|
|
|
|
|
my $ret = PDL::abs($m); |
2500
|
|
|
|
|
|
|
bless $ret,'PDL'; |
2501
|
|
|
|
|
|
|
$ret = PDL::sumover($ret)->maximum; |
2502
|
|
|
|
|
|
|
return $trans ? PDL::Complex::Cscale($m->xchg(1,2),1/$ret->dummy(0)->xchg(0,1))->reshape(-1) : |
2503
|
|
|
|
|
|
|
PDL::Complex::Cscale($m,1/$ret->dummy(0))->reshape(-1); |
2504
|
|
|
|
|
|
|
} |
2505
|
|
|
|
|
|
|
|
2506
|
|
|
|
|
|
|
|
2507
|
|
|
|
|
|
|
|
2508
|
|
|
|
|
|
|
|
2509
|
|
|
|
|
|
|
#TODO: inplace ? |
2510
|
|
|
|
|
|
|
|
2511
|
|
|
|
|
|
|
=head2 mgschur |
2512
|
|
|
|
|
|
|
|
2513
|
|
|
|
|
|
|
=for ref |
2514
|
|
|
|
|
|
|
|
2515
|
|
|
|
|
|
|
Computes generalized Schur decomposition of the pair (A,B). |
2516
|
|
|
|
|
|
|
|
2517
|
|
|
|
|
|
|
A = Q x S x Z' |
2518
|
|
|
|
|
|
|
B = Q x T x Z' |
2519
|
|
|
|
|
|
|
|
2520
|
|
|
|
|
|
|
Uses L or L |
2521
|
|
|
|
|
|
|
from Lapack. |
2522
|
|
|
|
|
|
|
Works on transposed array. |
2523
|
|
|
|
|
|
|
|
2524
|
|
|
|
|
|
|
=for usage |
2525
|
|
|
|
|
|
|
|
2526
|
|
|
|
|
|
|
( PDL(schur S), PDL(schur T), PDL(alpha), PDL(beta), HASH{result}) = mgschur(PDL(A), PDL(B), SCALAR(left schur vector),SCALAR(right schur vector),SCALAR(left eigenvector), SCALAR(right eigenvector), SCALAR(select_func), SCALAR(backtransform), SCALAR(scale)) |
2527
|
|
|
|
|
|
|
left schur vector : Left Schur vectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
2528
|
|
|
|
|
|
|
right schur vector : Right Schur vectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
2529
|
|
|
|
|
|
|
left eigenvector : Left eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
2530
|
|
|
|
|
|
|
right eigenvector : Right eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
2531
|
|
|
|
|
|
|
select_func : Select_func is used to select eigenvalues to sort. |
2532
|
|
|
|
|
|
|
to the top left of the Schur form. |
2533
|
|
|
|
|
|
|
An eigenvalue w = wr(j)+sqrt(-1)*wi(j) is selected if |
2534
|
|
|
|
|
|
|
PerlInt select_func(PDL::Complex(alpha),PDL | PDL::Complex (beta)) is true; |
2535
|
|
|
|
|
|
|
Note that a selected complex eigenvalue may no longer |
2536
|
|
|
|
|
|
|
satisfy select_func = 1 after ordering, since |
2537
|
|
|
|
|
|
|
ordering may change the value of complex eigenvalues |
2538
|
|
|
|
|
|
|
(especially if the eigenvalue is ill-conditioned). |
2539
|
|
|
|
|
|
|
All eigenvalues/vectors are selected if select_func is undefined. |
2540
|
|
|
|
|
|
|
backtransform : Whether or not backtransforms eigenvectors to those of (A,B). |
2541
|
|
|
|
|
|
|
Only supported if right and/or left schur vector are computed, |
2542
|
|
|
|
|
|
|
scale : Whether or not computed eigenvectors are scaled so the largest component |
2543
|
|
|
|
|
|
|
will have abs(real part) + abs(imag. part) = 1, default = 1 |
2544
|
|
|
|
|
|
|
|
2545
|
|
|
|
|
|
|
Returned values : |
2546
|
|
|
|
|
|
|
Schur form S, |
2547
|
|
|
|
|
|
|
Schur form T, |
2548
|
|
|
|
|
|
|
alpha, |
2549
|
|
|
|
|
|
|
beta (eigenvalues = alpha/beta), |
2550
|
|
|
|
|
|
|
HASH{info}: info output from gges/cgges. |
2551
|
|
|
|
|
|
|
HASH{SL}: left Schur vectors if requested |
2552
|
|
|
|
|
|
|
HASH{SR}: right Schur vectors if requested |
2553
|
|
|
|
|
|
|
HASH{VL}: left eigenvectors if requested |
2554
|
|
|
|
|
|
|
HASH{VR}: right eigenvectors if requested |
2555
|
|
|
|
|
|
|
HASH{n} : Number of eigenvalues selected if select_func is defined. |
2556
|
|
|
|
|
|
|
|
2557
|
|
|
|
|
|
|
=for example |
2558
|
|
|
|
|
|
|
|
2559
|
|
|
|
|
|
|
my $a = random(10,10); |
2560
|
|
|
|
|
|
|
my $b = random(10,10); |
2561
|
|
|
|
|
|
|
my ($S,$T) = mgschur($a,$b); |
2562
|
|
|
|
|
|
|
sub select{ |
2563
|
|
|
|
|
|
|
my ($alpha,$beta) = @_; |
2564
|
|
|
|
|
|
|
return $alpha->Cabs < abs($beta) ? 1 : 0; |
2565
|
|
|
|
|
|
|
} |
2566
|
|
|
|
|
|
|
my ($S, $T, $alpha, $beta, %res) = mgschur( $a, $b, 1, 1, 1, 1,\&select); |
2567
|
|
|
|
|
|
|
|
2568
|
|
|
|
|
|
|
=cut |
2569
|
|
|
|
|
|
|
|
2570
|
|
|
|
|
|
|
|
2571
|
|
|
|
|
|
|
sub mgschur{ |
2572
|
|
|
|
|
|
|
my $m = shift; |
2573
|
|
|
|
|
|
|
$m->mgschur(@_); |
2574
|
|
|
|
|
|
|
} |
2575
|
|
|
|
|
|
|
|
2576
|
|
|
|
|
|
|
sub PDL::mgschur{ |
2577
|
|
|
|
|
|
|
my($m, $p, $jobvsl, $jobvsr, $jobvl, $jobvr, $select_func, $mult, $norm) = @_; |
2578
|
|
|
|
|
|
|
my @mdims = $m->dims; |
2579
|
|
|
|
|
|
|
my @pdims = $p->dims; |
2580
|
|
|
|
|
|
|
|
2581
|
|
|
|
|
|
|
barf("mgschur: Require square matrices of same order") |
2582
|
|
|
|
|
|
|
unless( $mdims[0] == $mdims[1] && $pdims[0] == $pdims[1] && $mdims[0] == $pdims[0]); |
2583
|
|
|
|
|
|
|
barf("mgschur: thread doesn't supported for selected vectors") |
2584
|
|
|
|
|
|
|
if ($select_func && ((@mdims > 2) || (@pdims > 2)) && |
2585
|
|
|
|
|
|
|
($jobvsl == 2 || $jobvsr == 2 || $jobvl == 2 || $jobvr == 2)); |
2586
|
|
|
|
|
|
|
|
2587
|
|
|
|
|
|
|
|
2588
|
|
|
|
|
|
|
my ($w, $vsl, $vsr, $info, $type, $select,$sdim, $vr,$vl, $mm, $pp, %ret, $beta); |
2589
|
|
|
|
|
|
|
|
2590
|
|
|
|
|
|
|
$mult = 1 unless defined($mult); |
2591
|
|
|
|
|
|
|
$norm = 1 unless defined($norm); |
2592
|
|
|
|
|
|
|
$type = $m->type; |
2593
|
|
|
|
|
|
|
$select = $select_func ? pdl(long,1) : pdl(long,0); |
2594
|
|
|
|
|
|
|
|
2595
|
|
|
|
|
|
|
$info = null; |
2596
|
|
|
|
|
|
|
$sdim = null; |
2597
|
|
|
|
|
|
|
$mm = $m->is_inplace ? $m->xchg(0,1) : $m->xchg(0,1)->copy; |
2598
|
|
|
|
|
|
|
$pp = $p->is_inplace ? $p->xchg(0,1) : $p->xchg(0,1)->copy; |
2599
|
|
|
|
|
|
|
|
2600
|
|
|
|
|
|
|
my ($select_f, $wi, $wtmp, $betai); |
2601
|
|
|
|
|
|
|
if ($select_func){ |
2602
|
|
|
|
|
|
|
$select_f= sub{ |
2603
|
|
|
|
|
|
|
&$select_func(PDL::Complex::complex(pdl($type,@_[0..1])),pdl($_[2])); |
2604
|
|
|
|
|
|
|
}; |
2605
|
|
|
|
|
|
|
} |
2606
|
|
|
|
|
|
|
$wtmp = null; |
2607
|
|
|
|
|
|
|
$wi = null; |
2608
|
|
|
|
|
|
|
$beta = null; |
2609
|
|
|
|
|
|
|
# $vsl = $jobvsl ? PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]) : |
2610
|
|
|
|
|
|
|
# pdl($type,[[0]]); |
2611
|
|
|
|
|
|
|
|
2612
|
|
|
|
|
|
|
# Lapack always write in VSL (g77 3.3) ??? |
2613
|
|
|
|
|
|
|
$vsl = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]); |
2614
|
|
|
|
|
|
|
$vsr = $jobvsr ? PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]) : |
2615
|
|
|
|
|
|
|
pdl($type,[[0]]); |
2616
|
|
|
|
|
|
|
$mm->gges( $jobvsl, $jobvsr, $select, $pp, $wtmp, $wi, $beta, $vsl, $vsr, $sdim, $info, $select_f); |
2617
|
|
|
|
|
|
|
|
2618
|
|
|
|
|
|
|
if ($info->max > 0 && $_laerror){ |
2619
|
|
|
|
|
|
|
my ($index, @list); |
2620
|
|
|
|
|
|
|
$index = which((($info > 0)+($info <=$mdims[0])) == 2); |
2621
|
|
|
|
|
|
|
unless ($index->isempty){ |
2622
|
|
|
|
|
|
|
@list = $index->list; |
2623
|
|
|
|
|
|
|
laerror("mgschur: The QZ algorithm failed to converge for matrix (PDL(s) @list): \$info = $info"); |
2624
|
|
|
|
|
|
|
print ("Returning converged eigenvalues\n"); |
2625
|
|
|
|
|
|
|
} |
2626
|
|
|
|
|
|
|
$index = which((($info > 0)+($info <=($mdims[0]+1))) == 2); |
2627
|
|
|
|
|
|
|
unless ($index->isempty){ |
2628
|
|
|
|
|
|
|
@list = $index->list; |
2629
|
|
|
|
|
|
|
laerror("mgschur: Error in hgeqz for matrix (PDL(s) @list): \$info = $info"); |
2630
|
|
|
|
|
|
|
} |
2631
|
|
|
|
|
|
|
if ($select_func){ |
2632
|
|
|
|
|
|
|
$index = which((($info > 0)+($info == ($mdims[0]+3))) == 2); |
2633
|
|
|
|
|
|
|
unless ($index->isempty){ |
2634
|
|
|
|
|
|
|
laerror("mgschur: The eigenvalues could not be reordered because some\n". |
2635
|
|
|
|
|
|
|
"eigenvalues were too close to separate (the problem". |
2636
|
|
|
|
|
|
|
"is very ill-conditioned) for PDL(s) @list: \$info = $info"); |
2637
|
|
|
|
|
|
|
} |
2638
|
|
|
|
|
|
|
} |
2639
|
|
|
|
|
|
|
} |
2640
|
|
|
|
|
|
|
|
2641
|
|
|
|
|
|
|
if ($select_func){ |
2642
|
|
|
|
|
|
|
if ($jobvsl == 2 || $jobvsr == 2 || $jobvl == 2 || $jobvr == 2){ |
2643
|
|
|
|
|
|
|
if ($info == ($mdims[0] + 2)){ |
2644
|
|
|
|
|
|
|
warn("mgschur: The Schur form no longer satisfy select_func = 1\n because of roundoff or underflow\n") if $_laerror; |
2645
|
|
|
|
|
|
|
#TODO : Check sdim and lapack |
2646
|
|
|
|
|
|
|
$sdim+=1 if ($sdim < $mdims[0] && $wi($sdim) != 0 && $wi($sdim-1) == -$wi($sdim)); |
2647
|
|
|
|
|
|
|
} |
2648
|
|
|
|
|
|
|
} |
2649
|
|
|
|
|
|
|
elsif($_laerror){ |
2650
|
|
|
|
|
|
|
my $index = which((($info > 0)+($info == ($mdims[0]+2))) == 2); |
2651
|
|
|
|
|
|
|
unless ($index->isempty){ |
2652
|
|
|
|
|
|
|
my @list = $index->list; |
2653
|
|
|
|
|
|
|
warn("mgschur: The Schur form no longer satisfy select_func = 1\n because". |
2654
|
|
|
|
|
|
|
"of roundoff or underflow for PDL(s) @list: \$info = $info\n"); |
2655
|
|
|
|
|
|
|
} |
2656
|
|
|
|
|
|
|
} |
2657
|
|
|
|
|
|
|
if ($jobvl == 2){ |
2658
|
|
|
|
|
|
|
if (!$sdim){ |
2659
|
|
|
|
|
|
|
$ret{VL} = PDL::Complex->null; |
2660
|
|
|
|
|
|
|
$jobvl = 0; |
2661
|
|
|
|
|
|
|
} |
2662
|
|
|
|
|
|
|
} |
2663
|
|
|
|
|
|
|
if ($jobvr == 2){ |
2664
|
|
|
|
|
|
|
if(!$sdim){ |
2665
|
|
|
|
|
|
|
$ret{VR} = PDL::Complex->null; |
2666
|
|
|
|
|
|
|
$jobvr = 0; |
2667
|
|
|
|
|
|
|
} |
2668
|
|
|
|
|
|
|
} |
2669
|
|
|
|
|
|
|
$ret{n} = $sdim; |
2670
|
|
|
|
|
|
|
} |
2671
|
|
|
|
|
|
|
|
2672
|
|
|
|
|
|
|
if ($jobvl || $jobvr){ |
2673
|
|
|
|
|
|
|
my ($sel, $job, $wtmpi, $wtmpr, $sdims); |
2674
|
|
|
|
|
|
|
unless ($jobvr && $jobvl){ |
2675
|
|
|
|
|
|
|
$job = $jobvl ? 2 : 1; |
2676
|
|
|
|
|
|
|
} |
2677
|
|
|
|
|
|
|
if ($select_func){ |
2678
|
|
|
|
|
|
|
if ($jobvl == 1 || $jobvr == 1 || $mult){ |
2679
|
|
|
|
|
|
|
$sdims = null; |
2680
|
|
|
|
|
|
|
if ($jobvl){ |
2681
|
|
|
|
|
|
|
if ($jobvsl){ |
2682
|
|
|
|
|
|
|
$vl = $vsl->copy; |
2683
|
|
|
|
|
|
|
} |
2684
|
|
|
|
|
|
|
else{ |
2685
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]); |
2686
|
|
|
|
|
|
|
$mult = 0; |
2687
|
|
|
|
|
|
|
} |
2688
|
|
|
|
|
|
|
} |
2689
|
|
|
|
|
|
|
if ($jobvr){ |
2690
|
|
|
|
|
|
|
if ($jobvsr){ |
2691
|
|
|
|
|
|
|
$vr = $vsr->copy; |
2692
|
|
|
|
|
|
|
} |
2693
|
|
|
|
|
|
|
else{ |
2694
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]); |
2695
|
|
|
|
|
|
|
$mult = 0; |
2696
|
|
|
|
|
|
|
} |
2697
|
|
|
|
|
|
|
} |
2698
|
|
|
|
|
|
|
|
2699
|
|
|
|
|
|
|
$mm->tgevc($job, $mult, $pp, $sel, $vl, $vr, $sdims, my $infos=null); |
2700
|
|
|
|
|
|
|
if ($jobvr){ |
2701
|
|
|
|
|
|
|
if($norm){ |
2702
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); |
2703
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
2704
|
|
|
|
|
|
|
$ret{VR} = $jobvr == 2 ? magn_norm($vr(,,:($sdim-1)),1) : magn_norm($vr,1); |
2705
|
|
|
|
|
|
|
|
2706
|
|
|
|
|
|
|
} |
2707
|
|
|
|
|
|
|
else{ |
2708
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); |
2709
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
2710
|
|
|
|
|
|
|
$ret{VR} = $jobvr == 2 ? $vr(,:($sdim-1))->sever : $vr; |
2711
|
|
|
|
|
|
|
} |
2712
|
|
|
|
|
|
|
} |
2713
|
|
|
|
|
|
|
if ($jobvl){ |
2714
|
|
|
|
|
|
|
if ($norm){ |
2715
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); |
2716
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
2717
|
|
|
|
|
|
|
$ret{VL} = $jobvl == 2 ? magn_norm($vl(,,:($sdim-1)),1) : magn_norm($vl,1); |
2718
|
|
|
|
|
|
|
|
2719
|
|
|
|
|
|
|
} |
2720
|
|
|
|
|
|
|
else{ |
2721
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); |
2722
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
2723
|
|
|
|
|
|
|
$ret{VL} = $jobvl == 2 ? $vl(,:($sdim-1))->sever : $vl; |
2724
|
|
|
|
|
|
|
} |
2725
|
|
|
|
|
|
|
} |
2726
|
|
|
|
|
|
|
} |
2727
|
|
|
|
|
|
|
else{ |
2728
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $mdims[1], $sdim) if $jobvr; |
2729
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $mdims[1], $sdim) if $jobvl; |
2730
|
|
|
|
|
|
|
$sel = zeroes($mdims[1]); |
2731
|
|
|
|
|
|
|
$sel(:($sdim-1)) .= 1; |
2732
|
|
|
|
|
|
|
$mm->tgevc($job, 2, $pp, $sel, $vl, $vr, $sdim, my $infos = null); |
2733
|
|
|
|
|
|
|
$wtmpr = $wtmp(:($sdim-1)); |
2734
|
|
|
|
|
|
|
$wtmpi = $wi(:($sdim-1)); |
2735
|
|
|
|
|
|
|
if ($jobvr){ |
2736
|
|
|
|
|
|
|
if ($norm){ |
2737
|
|
|
|
|
|
|
(undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr,1); |
2738
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
2739
|
|
|
|
|
|
|
$ret{VR} = magn_norm($vr,1); |
2740
|
|
|
|
|
|
|
} |
2741
|
|
|
|
|
|
|
else{ |
2742
|
|
|
|
|
|
|
(undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr->xchg(0,1),0); |
2743
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
2744
|
|
|
|
|
|
|
$ret{VR} = $vr; |
2745
|
|
|
|
|
|
|
} |
2746
|
|
|
|
|
|
|
} |
2747
|
|
|
|
|
|
|
if ($jobvl){ |
2748
|
|
|
|
|
|
|
if ($norm){ |
2749
|
|
|
|
|
|
|
(undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl,1); |
2750
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
2751
|
|
|
|
|
|
|
$ret{VL} = magn_norm($vl,1); |
2752
|
|
|
|
|
|
|
|
2753
|
|
|
|
|
|
|
} |
2754
|
|
|
|
|
|
|
else{ |
2755
|
|
|
|
|
|
|
(undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl->xchg(0,1),0); |
2756
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
2757
|
|
|
|
|
|
|
$ret{VL} = $vl; |
2758
|
|
|
|
|
|
|
} |
2759
|
|
|
|
|
|
|
} |
2760
|
|
|
|
|
|
|
} |
2761
|
|
|
|
|
|
|
} |
2762
|
|
|
|
|
|
|
else{ |
2763
|
|
|
|
|
|
|
if ($jobvl){ |
2764
|
|
|
|
|
|
|
if ($jobvsl){ |
2765
|
|
|
|
|
|
|
$vl = $vsl->copy; |
2766
|
|
|
|
|
|
|
} |
2767
|
|
|
|
|
|
|
else{ |
2768
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]); |
2769
|
|
|
|
|
|
|
$mult = 0; |
2770
|
|
|
|
|
|
|
} |
2771
|
|
|
|
|
|
|
} |
2772
|
|
|
|
|
|
|
if ($jobvr){ |
2773
|
|
|
|
|
|
|
if ($jobvsr){ |
2774
|
|
|
|
|
|
|
$vr = $vsr->copy; |
2775
|
|
|
|
|
|
|
} |
2776
|
|
|
|
|
|
|
else{ |
2777
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1],@mdims[2..$#mdims]); |
2778
|
|
|
|
|
|
|
$mult = 0; |
2779
|
|
|
|
|
|
|
} |
2780
|
|
|
|
|
|
|
} |
2781
|
|
|
|
|
|
|
|
2782
|
|
|
|
|
|
|
$mm->tgevc($job, $mult, $pp, $sel, $vl, $vr, $sdim, my $infos=null); |
2783
|
|
|
|
|
|
|
if ($jobvl){ |
2784
|
|
|
|
|
|
|
if ($norm){ |
2785
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); |
2786
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
2787
|
|
|
|
|
|
|
$ret{VL} = magn_norm($vl,1); |
2788
|
|
|
|
|
|
|
} |
2789
|
|
|
|
|
|
|
else{ |
2790
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); |
2791
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
2792
|
|
|
|
|
|
|
$ret{VL} = $vl; |
2793
|
|
|
|
|
|
|
} |
2794
|
|
|
|
|
|
|
} |
2795
|
|
|
|
|
|
|
if ($jobvr){ |
2796
|
|
|
|
|
|
|
if ($norm){ |
2797
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); |
2798
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
2799
|
|
|
|
|
|
|
$ret{VR} = magn_norm($vr,1); |
2800
|
|
|
|
|
|
|
} |
2801
|
|
|
|
|
|
|
else{ |
2802
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); |
2803
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
2804
|
|
|
|
|
|
|
$ret{VR} = $vr; |
2805
|
|
|
|
|
|
|
} |
2806
|
|
|
|
|
|
|
} |
2807
|
|
|
|
|
|
|
} |
2808
|
|
|
|
|
|
|
} |
2809
|
|
|
|
|
|
|
$w = PDL::Complex::ecplx ($wtmp, $wi); |
2810
|
|
|
|
|
|
|
|
2811
|
|
|
|
|
|
|
if ($jobvsr == 2 && $select_func) { |
2812
|
|
|
|
|
|
|
$vsr = $sdim ? $vsr->xchg(0,1)->(:($sdim-1),) ->sever : null; |
2813
|
|
|
|
|
|
|
$ret{SR} = $vsr; |
2814
|
|
|
|
|
|
|
} |
2815
|
|
|
|
|
|
|
elsif($jobvsr){ |
2816
|
|
|
|
|
|
|
$vsr = $vsr->xchg(0,1)->sever; |
2817
|
|
|
|
|
|
|
$ret{SR} = $vsr; |
2818
|
|
|
|
|
|
|
} |
2819
|
|
|
|
|
|
|
|
2820
|
|
|
|
|
|
|
if ($jobvsl == 2 && $select_func) { |
2821
|
|
|
|
|
|
|
$vsl = $sdim ? $vsl->xchg(0,1)->(:($sdim-1),) ->sever : null; |
2822
|
|
|
|
|
|
|
$ret{SL} = $vsl; |
2823
|
|
|
|
|
|
|
} |
2824
|
|
|
|
|
|
|
elsif($jobvsl){ |
2825
|
|
|
|
|
|
|
$vsl = $vsl->xchg(0,1)->sever; |
2826
|
|
|
|
|
|
|
$ret{SL} = $vsl; |
2827
|
|
|
|
|
|
|
} |
2828
|
|
|
|
|
|
|
$ret{info} = $info; |
2829
|
|
|
|
|
|
|
$m = $mm->xchg(0,1)->sever unless $m->is_inplace(0); |
2830
|
|
|
|
|
|
|
$p = $pp->xchg(0,1)->sever unless $p->is_inplace(0); |
2831
|
|
|
|
|
|
|
return ($m, $p, $w, $beta, %ret); |
2832
|
|
|
|
|
|
|
|
2833
|
|
|
|
|
|
|
} |
2834
|
|
|
|
|
|
|
|
2835
|
|
|
|
|
|
|
|
2836
|
|
|
|
|
|
|
sub PDL::Complex::mgschur{ |
2837
|
|
|
|
|
|
|
my($m, $p, $jobvsl, $jobvsr, $jobvl, $jobvr, $select_func, $mult, $norm) = @_; |
2838
|
|
|
|
|
|
|
my @mdims = $m->dims; |
2839
|
|
|
|
|
|
|
my @pdims = $p->dims; |
2840
|
|
|
|
|
|
|
|
2841
|
|
|
|
|
|
|
barf("mgschur: Require square matrices of same order") |
2842
|
|
|
|
|
|
|
unless( $mdims[2] == $mdims[1] && $pdims[2] == $pdims[1] && $mdims[1] == $pdims[1]); |
2843
|
|
|
|
|
|
|
barf("mgschur: thread doesn't supported for selected vectors") |
2844
|
|
|
|
|
|
|
if ($select_func && ((@mdims > 2) || (@pdims > 2)) && |
2845
|
|
|
|
|
|
|
($jobvsl == 2 || $jobvsr == 2 || $jobvl == 2 || $jobvr == 2)); |
2846
|
|
|
|
|
|
|
|
2847
|
|
|
|
|
|
|
|
2848
|
|
|
|
|
|
|
my ($w, $vsl, $vsr, $info, $type, $select,$sdim, $vr,$vl, $mm, $pp, %ret, $beta); |
2849
|
|
|
|
|
|
|
|
2850
|
|
|
|
|
|
|
$mult = 1 unless defined($mult); |
2851
|
|
|
|
|
|
|
$norm = 1 unless defined($norm); |
2852
|
|
|
|
|
|
|
$type = $m->type; |
2853
|
|
|
|
|
|
|
$select = $select_func ? pdl(long,1) : pdl(long,0); |
2854
|
|
|
|
|
|
|
|
2855
|
|
|
|
|
|
|
$info = null; |
2856
|
|
|
|
|
|
|
$sdim = null; |
2857
|
|
|
|
|
|
|
$mm = $m->is_inplace ? $m->xchg(1,2) : $m->xchg(1,2)->copy; |
2858
|
|
|
|
|
|
|
$pp = $p->is_inplace ? $p->xchg(1,2) : $p->xchg(1,2)->copy; |
2859
|
|
|
|
|
|
|
|
2860
|
|
|
|
|
|
|
$w = PDL::Complex->null; |
2861
|
|
|
|
|
|
|
$beta = PDL::Complex->null; |
2862
|
|
|
|
|
|
|
$vsr = $jobvsr ? PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1],@mdims[3..$#mdims]) : |
2863
|
|
|
|
|
|
|
pdl($type,[0,0]); |
2864
|
|
|
|
|
|
|
# $vsl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]); |
2865
|
|
|
|
|
|
|
$vsl = $jobvsl ? PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1],@mdims[3..$#mdims]) : |
2866
|
|
|
|
|
|
|
pdl($type,[0,0]); |
2867
|
|
|
|
|
|
|
|
2868
|
|
|
|
|
|
|
$mm->cgges( $jobvsl, $jobvsr, $select, $pp, $w, $beta, $vsl, $vsr, $sdim, $info, $select_func); |
2869
|
|
|
|
|
|
|
if ($info->max > 0 && $_laerror){ |
2870
|
|
|
|
|
|
|
my ($index, @list); |
2871
|
|
|
|
|
|
|
$index = which((($info > 0)+($info <=$mdims[1])) == 2); |
2872
|
|
|
|
|
|
|
unless ($index->isempty){ |
2873
|
|
|
|
|
|
|
@list = $index->list; |
2874
|
|
|
|
|
|
|
laerror("mgschur: The QZ algorithm failed to converge for matrix (PDL(s) @list): \$info = $info"); |
2875
|
|
|
|
|
|
|
print ("Returning converged eigenvalues\n"); |
2876
|
|
|
|
|
|
|
} |
2877
|
|
|
|
|
|
|
$index = which((($info > 0)+($info <=($mdims[1]+1))) == 2); |
2878
|
|
|
|
|
|
|
unless ($index->isempty){ |
2879
|
|
|
|
|
|
|
@list = $index->list; |
2880
|
|
|
|
|
|
|
laerror("mgschur: Error in hgeqz for matrix (PDL(s) @list): \$info = $info"); |
2881
|
|
|
|
|
|
|
} |
2882
|
|
|
|
|
|
|
if ($select_func){ |
2883
|
|
|
|
|
|
|
$index = which((($info > 0)+($info == ($mdims[1]+3))) == 2); |
2884
|
|
|
|
|
|
|
unless ($index->isempty){ |
2885
|
|
|
|
|
|
|
laerror("mgschur: The eigenvalues could not be reordered because some\n". |
2886
|
|
|
|
|
|
|
"eigenvalues were too close to separate (the problem". |
2887
|
|
|
|
|
|
|
"is very ill-conditioned) for PDL(s) @list: \$info = $info"); |
2888
|
|
|
|
|
|
|
} |
2889
|
|
|
|
|
|
|
} |
2890
|
|
|
|
|
|
|
} |
2891
|
|
|
|
|
|
|
|
2892
|
|
|
|
|
|
|
if ($select_func){ |
2893
|
|
|
|
|
|
|
if ($_laerror){ |
2894
|
|
|
|
|
|
|
if (($jobvsl == 2 || $jobvsr == 2 || $jobvl == 2 || $jobvr == 2) && $info == ($mdims[1] + 2)){ |
2895
|
|
|
|
|
|
|
warn("mgschur: The Schur form no longer satisfy select_func = 1\n because of roundoff or underflow\n"); |
2896
|
|
|
|
|
|
|
} |
2897
|
|
|
|
|
|
|
else{ |
2898
|
|
|
|
|
|
|
my $index = which((($info > 0)+($info == ($mdims[1]+2))) == 2); |
2899
|
|
|
|
|
|
|
unless ($index->isempty){ |
2900
|
|
|
|
|
|
|
my @list = $index->list; |
2901
|
|
|
|
|
|
|
warn("mgschur: The Schur form no longer satisfy select_func = 1\n because". |
2902
|
|
|
|
|
|
|
"of roundoff or underflow for PDL(s) @list: \$info = $info\n"); |
2903
|
|
|
|
|
|
|
} |
2904
|
|
|
|
|
|
|
} |
2905
|
|
|
|
|
|
|
} |
2906
|
|
|
|
|
|
|
if ($jobvl == 2){ |
2907
|
|
|
|
|
|
|
if (!$sdim){ |
2908
|
|
|
|
|
|
|
$ret{VL} = PDL::Complex->null; |
2909
|
|
|
|
|
|
|
$jobvl = 0; |
2910
|
|
|
|
|
|
|
} |
2911
|
|
|
|
|
|
|
} |
2912
|
|
|
|
|
|
|
if ($jobvr == 2){ |
2913
|
|
|
|
|
|
|
if(!$sdim){ |
2914
|
|
|
|
|
|
|
$ret{VR} = PDL::Complex->null; |
2915
|
|
|
|
|
|
|
$jobvr = 0; |
2916
|
|
|
|
|
|
|
} |
2917
|
|
|
|
|
|
|
} |
2918
|
|
|
|
|
|
|
$ret{n} = $sdim; |
2919
|
|
|
|
|
|
|
} |
2920
|
|
|
|
|
|
|
|
2921
|
|
|
|
|
|
|
if ($jobvl || $jobvr){ |
2922
|
|
|
|
|
|
|
my ($sel, $job, $sdims); |
2923
|
|
|
|
|
|
|
unless ($jobvr && $jobvl){ |
2924
|
|
|
|
|
|
|
$job = $jobvl ? 2 : 1; |
2925
|
|
|
|
|
|
|
} |
2926
|
|
|
|
|
|
|
if ($select_func){ |
2927
|
|
|
|
|
|
|
if ($jobvl == 1 || $jobvr == 1 || $mult){ |
2928
|
|
|
|
|
|
|
$sdims = null; |
2929
|
|
|
|
|
|
|
if ($jobvl){ |
2930
|
|
|
|
|
|
|
if ($jobvsl){ |
2931
|
|
|
|
|
|
|
$vl = $vsl->copy; |
2932
|
|
|
|
|
|
|
} |
2933
|
|
|
|
|
|
|
else{ |
2934
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1],@mdims[3..$#mdims]); |
2935
|
|
|
|
|
|
|
$mult = 0; |
2936
|
|
|
|
|
|
|
} |
2937
|
|
|
|
|
|
|
} |
2938
|
|
|
|
|
|
|
if ($jobvr){ |
2939
|
|
|
|
|
|
|
if ($jobvsr){ |
2940
|
|
|
|
|
|
|
$vr = $vsr->copy; |
2941
|
|
|
|
|
|
|
} |
2942
|
|
|
|
|
|
|
else{ |
2943
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1],@mdims[3..$#mdims]); |
2944
|
|
|
|
|
|
|
$mult = 0; |
2945
|
|
|
|
|
|
|
} |
2946
|
|
|
|
|
|
|
} |
2947
|
|
|
|
|
|
|
$mm->ctgevc($job, $mult, $pp, $sel, $vl, $vr, $sdims, my $infos=null); |
2948
|
|
|
|
|
|
|
if ($jobvr){ |
2949
|
|
|
|
|
|
|
if ($norm){ |
2950
|
|
|
|
|
|
|
$ret{VR} = $jobvr == 2 ? magn_norm($vr(,,:($sdim-1)),1) : magn_norm($vr,1); |
2951
|
|
|
|
|
|
|
} |
2952
|
|
|
|
|
|
|
else{ |
2953
|
|
|
|
|
|
|
$ret{VR} = $jobvr == 2 ? $vr(,,:($sdim-1))->xchg(1,2)->sever : $vr->xchg(1,2)->sever; |
2954
|
|
|
|
|
|
|
} |
2955
|
|
|
|
|
|
|
} |
2956
|
|
|
|
|
|
|
if ($jobvl){ |
2957
|
|
|
|
|
|
|
if ($norm){ |
2958
|
|
|
|
|
|
|
$ret{VL} = $jobvl == 2 ? magn_norm($vl(,,:($sdim-1)),1) : magn_norm($vl,1); |
2959
|
|
|
|
|
|
|
} |
2960
|
|
|
|
|
|
|
else{ |
2961
|
|
|
|
|
|
|
$ret{VL} = $jobvl == 2 ? $vl(,,:($sdim-1))->xchg(1,2)->sever : $vl->xchg(1,2)->sever; |
2962
|
|
|
|
|
|
|
} |
2963
|
|
|
|
|
|
|
} |
2964
|
|
|
|
|
|
|
} |
2965
|
|
|
|
|
|
|
else{ |
2966
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2,$mdims[1], $sdim) if $jobvr;; |
2967
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $sdim) if $jobvl;; |
2968
|
|
|
|
|
|
|
$sel = zeroes($mdims[1]); |
2969
|
|
|
|
|
|
|
$sel(:($sdim-1)) .= 1; |
2970
|
|
|
|
|
|
|
$mm->ctgevc($job, 2, $pp, $sel, $vl, $vr, $sdim, my $infos=null); |
2971
|
|
|
|
|
|
|
if ($jobvl){ |
2972
|
|
|
|
|
|
|
$ret{VL} = $norm ? magn_norm($vl,1) : $vl->xchg(1,2)->sever; |
2973
|
|
|
|
|
|
|
} |
2974
|
|
|
|
|
|
|
if ($jobvr){ |
2975
|
|
|
|
|
|
|
$ret{VR} = $norm ? magn_norm($vr,1) : $vr->xchg(1,2)->sever; |
2976
|
|
|
|
|
|
|
} |
2977
|
|
|
|
|
|
|
} |
2978
|
|
|
|
|
|
|
} |
2979
|
|
|
|
|
|
|
else{ |
2980
|
|
|
|
|
|
|
if ($jobvl){ |
2981
|
|
|
|
|
|
|
if ($jobvsl){ |
2982
|
|
|
|
|
|
|
$vl = $vsl->copy; |
2983
|
|
|
|
|
|
|
} |
2984
|
|
|
|
|
|
|
else{ |
2985
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1],@mdims[3..$#mdims]); |
2986
|
|
|
|
|
|
|
$mult = 0; |
2987
|
|
|
|
|
|
|
} |
2988
|
|
|
|
|
|
|
} |
2989
|
|
|
|
|
|
|
if ($jobvr){ |
2990
|
|
|
|
|
|
|
if ($jobvsr){ |
2991
|
|
|
|
|
|
|
$vr = $vsr->copy; |
2992
|
|
|
|
|
|
|
} |
2993
|
|
|
|
|
|
|
else{ |
2994
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1],@mdims[3..$#mdims]); |
2995
|
|
|
|
|
|
|
$mult = 0; |
2996
|
|
|
|
|
|
|
} |
2997
|
|
|
|
|
|
|
} |
2998
|
|
|
|
|
|
|
$mm->ctgevc($job, $mult, $pp, $sel, $vl, $vr, $sdim, my $infos=null); |
2999
|
|
|
|
|
|
|
if ($jobvl){ |
3000
|
|
|
|
|
|
|
$ret{VL} = $norm ? magn_norm($vl,1) : $vl->xchg(1,2)->sever; |
3001
|
|
|
|
|
|
|
} |
3002
|
|
|
|
|
|
|
if ($jobvr){ |
3003
|
|
|
|
|
|
|
$ret{VR} = $norm ? magn_norm($vr,1) : $vr->xchg(1,2)->sever; |
3004
|
|
|
|
|
|
|
} |
3005
|
|
|
|
|
|
|
} |
3006
|
|
|
|
|
|
|
} |
3007
|
|
|
|
|
|
|
if ($jobvsl == 2 && $select_func) { |
3008
|
|
|
|
|
|
|
$vsl = $sdim ? $vsl->xchg(1,2)->(,:($sdim-1),) ->sever : PDL::Complex->null; |
3009
|
|
|
|
|
|
|
$ret{SL} = $vsl; |
3010
|
|
|
|
|
|
|
} |
3011
|
|
|
|
|
|
|
elsif($jobvsl){ |
3012
|
|
|
|
|
|
|
$vsl = $vsl->xchg(1,2)->sever; |
3013
|
|
|
|
|
|
|
$ret{SL} = $vsl; |
3014
|
|
|
|
|
|
|
} |
3015
|
|
|
|
|
|
|
if ($jobvsr == 2 && $select_func) { |
3016
|
|
|
|
|
|
|
$vsr = $sdim ? $vsr->xchg(1,2)->(,:($sdim-1),) ->sever : PDL::Complex->null; |
3017
|
|
|
|
|
|
|
$ret{SR} = $vsr; |
3018
|
|
|
|
|
|
|
} |
3019
|
|
|
|
|
|
|
elsif($jobvsr){ |
3020
|
|
|
|
|
|
|
$vsr = $vsr->xchg(1,2)->sever; |
3021
|
|
|
|
|
|
|
$ret{SR} = $vsr; |
3022
|
|
|
|
|
|
|
} |
3023
|
|
|
|
|
|
|
|
3024
|
|
|
|
|
|
|
$ret{info} = $info; |
3025
|
|
|
|
|
|
|
$m = $mm->xchg(1,2)->sever unless $m->is_inplace(0); |
3026
|
|
|
|
|
|
|
$p = $pp->xchg(1,2)->sever unless $p->is_inplace(0); |
3027
|
|
|
|
|
|
|
return ($m, $p, $w, $beta, %ret); |
3028
|
|
|
|
|
|
|
|
3029
|
|
|
|
|
|
|
} |
3030
|
|
|
|
|
|
|
|
3031
|
|
|
|
|
|
|
|
3032
|
|
|
|
|
|
|
|
3033
|
|
|
|
|
|
|
=head2 mgschurx |
3034
|
|
|
|
|
|
|
|
3035
|
|
|
|
|
|
|
=for ref |
3036
|
|
|
|
|
|
|
|
3037
|
|
|
|
|
|
|
Computes generalized Schur decomposition of the pair (A,B). |
3038
|
|
|
|
|
|
|
|
3039
|
|
|
|
|
|
|
A = Q x S x Z' |
3040
|
|
|
|
|
|
|
B = Q x T x Z' |
3041
|
|
|
|
|
|
|
|
3042
|
|
|
|
|
|
|
Uses L or L |
3043
|
|
|
|
|
|
|
from Lapack. Works on transposed array. |
3044
|
|
|
|
|
|
|
|
3045
|
|
|
|
|
|
|
=for usage |
3046
|
|
|
|
|
|
|
|
3047
|
|
|
|
|
|
|
( PDL(schur S), PDL(schur T), PDL(alpha), PDL(beta), HASH{result}) = mgschurx(PDL(A), PDL(B), SCALAR(left schur vector),SCALAR(right schur vector),SCALAR(left eigenvector), SCALAR(right eigenvector), SCALAR(select_func), SCALAR(sense), SCALAR(backtransform), SCALAR(scale)) |
3048
|
|
|
|
|
|
|
left schur vector : Left Schur vectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
3049
|
|
|
|
|
|
|
right schur vector : Right Schur vectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
3050
|
|
|
|
|
|
|
left eigenvector : Left eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
3051
|
|
|
|
|
|
|
right eigenvector : Right eigenvectors returned, none = 0 | all = 1 | selected = 2, default = 0 |
3052
|
|
|
|
|
|
|
select_func : Select_func is used to select eigenvalues to sort. |
3053
|
|
|
|
|
|
|
to the top left of the Schur form. |
3054
|
|
|
|
|
|
|
An eigenvalue w = wr(j)+sqrt(-1)*wi(j) is selected if |
3055
|
|
|
|
|
|
|
PerlInt select_func(PDL::Complex(alpha),PDL | PDL::Complex (beta)) is true; |
3056
|
|
|
|
|
|
|
Note that a selected complex eigenvalue may no longer |
3057
|
|
|
|
|
|
|
satisfy select_func = 1 after ordering, since |
3058
|
|
|
|
|
|
|
ordering may change the value of complex eigenvalues |
3059
|
|
|
|
|
|
|
(especially if the eigenvalue is ill-conditioned). |
3060
|
|
|
|
|
|
|
All eigenvalues/vectors are selected if select_func is undefined. |
3061
|
|
|
|
|
|
|
sense : Determines which reciprocal condition numbers will be computed. |
3062
|
|
|
|
|
|
|
0: None are computed |
3063
|
|
|
|
|
|
|
1: Computed for average of selected eigenvalues only |
3064
|
|
|
|
|
|
|
2: Computed for selected deflating subspaces only |
3065
|
|
|
|
|
|
|
3: Computed for both |
3066
|
|
|
|
|
|
|
If select_func is undefined, sense is not used. |
3067
|
|
|
|
|
|
|
|
3068
|
|
|
|
|
|
|
backtransform : Whether or not backtransforms eigenvectors to those of (A,B). |
3069
|
|
|
|
|
|
|
Only supported if right and/or left schur vector are computed, default = 1 |
3070
|
|
|
|
|
|
|
scale : Whether or not computed eigenvectors are scaled so the largest component |
3071
|
|
|
|
|
|
|
will have abs(real part) + abs(imag. part) = 1, default = 1 |
3072
|
|
|
|
|
|
|
|
3073
|
|
|
|
|
|
|
Returned values : |
3074
|
|
|
|
|
|
|
Schur form S, |
3075
|
|
|
|
|
|
|
Schur form T, |
3076
|
|
|
|
|
|
|
alpha, |
3077
|
|
|
|
|
|
|
beta (eigenvalues = alpha/beta), |
3078
|
|
|
|
|
|
|
HASH{info}: info output from gges/cgges. |
3079
|
|
|
|
|
|
|
HASH{SL}: left Schur vectors if requested |
3080
|
|
|
|
|
|
|
HASH{SR}: right Schur vectors if requested |
3081
|
|
|
|
|
|
|
HASH{VL}: left eigenvectors if requested |
3082
|
|
|
|
|
|
|
HASH{VR}: right eigenvectors if requested |
3083
|
|
|
|
|
|
|
HASH{rconde}: reciprocal condition numbers for average of selected eigenvalues if requested |
3084
|
|
|
|
|
|
|
HASH{rcondv}: reciprocal condition numbers for selected deflating subspaces if requested |
3085
|
|
|
|
|
|
|
HASH{n} : Number of eigenvalues selected if select_func is defined. |
3086
|
|
|
|
|
|
|
|
3087
|
|
|
|
|
|
|
=for example |
3088
|
|
|
|
|
|
|
|
3089
|
|
|
|
|
|
|
my $a = random(10,10); |
3090
|
|
|
|
|
|
|
my $b = random(10,10); |
3091
|
|
|
|
|
|
|
my ($S,$T) = mgschurx($a,$b); |
3092
|
|
|
|
|
|
|
sub select{ |
3093
|
|
|
|
|
|
|
my ($alpha,$beta) = @_; |
3094
|
|
|
|
|
|
|
return $alpha->Cabs < abs($beta) ? 1 : 0; |
3095
|
|
|
|
|
|
|
} |
3096
|
|
|
|
|
|
|
my ($S, $T, $alpha, $beta, %res) = mgschurx( $a, $b, 1, 1, 1, 1,\&select,3); |
3097
|
|
|
|
|
|
|
|
3098
|
|
|
|
|
|
|
|
3099
|
|
|
|
|
|
|
|
3100
|
|
|
|
|
|
|
=cut |
3101
|
|
|
|
|
|
|
|
3102
|
|
|
|
|
|
|
*mgschurx = \&PDL::mgschurx; |
3103
|
|
|
|
|
|
|
|
3104
|
|
|
|
|
|
|
sub PDL::mgschurx{ |
3105
|
|
|
|
|
|
|
my($m, $p, $jobvsl, $jobvsr, $jobvl, $jobvr, $select_func, $sense, $mult, $norm) = @_; |
3106
|
|
|
|
|
|
|
my (@mdims) = $m->dims; |
3107
|
|
|
|
|
|
|
my (@pdims) = $p->dims; |
3108
|
|
|
|
|
|
|
|
3109
|
|
|
|
|
|
|
barf("mgschurx: Require square matrices of same order") |
3110
|
|
|
|
|
|
|
unless( ( (@mdims == 2) || (@mdims == 3) )&& $mdims[-1] == $mdims[-2] && @mdims == @pdims && |
3111
|
|
|
|
|
|
|
$pdims[-1] == $pdims[-2] && $mdims[1] == $pdims[1]); |
3112
|
|
|
|
|
|
|
|
3113
|
|
|
|
|
|
|
my ($w, $vsl, $vsr, $info, $type, $select, $sdim, $rconde, $rcondv, %ret, $mm, $vl, $vr, $beta, $pp); |
3114
|
|
|
|
|
|
|
|
3115
|
|
|
|
|
|
|
$mult = 1 unless defined($mult); |
3116
|
|
|
|
|
|
|
$norm = 1 unless defined($norm); |
3117
|
|
|
|
|
|
|
$type = $m->type; |
3118
|
|
|
|
|
|
|
if ($select_func){ |
3119
|
|
|
|
|
|
|
$select = pdl(long 1); |
3120
|
|
|
|
|
|
|
$rconde = pdl($type,[0,0]); |
3121
|
|
|
|
|
|
|
$rcondv = pdl($type,[0,0]); |
3122
|
|
|
|
|
|
|
} |
3123
|
|
|
|
|
|
|
else{ |
3124
|
|
|
|
|
|
|
$select = pdl(long,0); |
3125
|
|
|
|
|
|
|
$sense = pdl(long,0); |
3126
|
|
|
|
|
|
|
$rconde = pdl($type,0); |
3127
|
|
|
|
|
|
|
$rcondv = pdl($type,0); |
3128
|
|
|
|
|
|
|
} |
3129
|
|
|
|
|
|
|
|
3130
|
|
|
|
|
|
|
$info = pdl(long,0); |
3131
|
|
|
|
|
|
|
$sdim = pdl(long,0); |
3132
|
|
|
|
|
|
|
|
3133
|
|
|
|
|
|
|
|
3134
|
|
|
|
|
|
|
$mm = $m->is_inplace ? $m->xchg(-1,-2) : $m->xchg(-1,-2)->copy; |
3135
|
|
|
|
|
|
|
$pp = $p->is_inplace ? $p->xchg(-1,-2) : $p->xchg(-1,-2)->copy; |
3136
|
|
|
|
|
|
|
|
3137
|
|
|
|
|
|
|
if (@mdims == 3){ |
3138
|
|
|
|
|
|
|
$w = PDL::Complex->null; |
3139
|
|
|
|
|
|
|
$beta = PDL::Complex->null; |
3140
|
|
|
|
|
|
|
# $vsl = $jobvsl ? PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]) : |
3141
|
|
|
|
|
|
|
# pdl($type,[0,0]); |
3142
|
|
|
|
|
|
|
$vsl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]); |
3143
|
|
|
|
|
|
|
$vsr = $jobvsr ? PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]) : |
3144
|
|
|
|
|
|
|
pdl($type,[0,0]); |
3145
|
|
|
|
|
|
|
$mm->cggesx( $jobvsl, $jobvsr, $select, $sense, $pp, $w, $beta, $vsl, $vsr, $sdim, $rconde, $rcondv,$info, $select_func); |
3146
|
|
|
|
|
|
|
if ($info){ |
3147
|
|
|
|
|
|
|
if ($info < $mdims[1]){ |
3148
|
|
|
|
|
|
|
laerror("mgschurx: The QZ algorithm failed to converge"); |
3149
|
|
|
|
|
|
|
print ("Returning converged eigenvalues\n") if $_laerror; |
3150
|
|
|
|
|
|
|
} |
3151
|
|
|
|
|
|
|
laerror("mgschurx: The eigenvalues could not be reordered because some\n". |
3152
|
|
|
|
|
|
|
"eigenvalues were too close to separate (the problem". |
3153
|
|
|
|
|
|
|
"is very ill-conditioned)") |
3154
|
|
|
|
|
|
|
if $info == ($mdims[1] + 3); |
3155
|
|
|
|
|
|
|
laerror("mgschurx: Error in hgeqz\n") |
3156
|
|
|
|
|
|
|
if $info == ($mdims[1] + 1); |
3157
|
|
|
|
|
|
|
|
3158
|
|
|
|
|
|
|
warn("mgschurx: The Schur form no longer satisfy select_func = 1\n because of roundoff or underflow\n") |
3159
|
|
|
|
|
|
|
if ($info == ($mdims[1] + 2) and $_laerror); |
3160
|
|
|
|
|
|
|
|
3161
|
|
|
|
|
|
|
} |
3162
|
|
|
|
|
|
|
|
3163
|
|
|
|
|
|
|
if ($select_func){ |
3164
|
|
|
|
|
|
|
if(!$sdim){ |
3165
|
|
|
|
|
|
|
if ($jobvl == 2){ |
3166
|
|
|
|
|
|
|
$ret{VL} = PDL::Complex->null; |
3167
|
|
|
|
|
|
|
$jobvl = 0; |
3168
|
|
|
|
|
|
|
} |
3169
|
|
|
|
|
|
|
if ($jobvr == 2){ |
3170
|
|
|
|
|
|
|
$ret{VR} = PDL::Complex->null; |
3171
|
|
|
|
|
|
|
$jobvr = 0; |
3172
|
|
|
|
|
|
|
} |
3173
|
|
|
|
|
|
|
} |
3174
|
|
|
|
|
|
|
$ret{n} = $sdim; |
3175
|
|
|
|
|
|
|
} |
3176
|
|
|
|
|
|
|
if ($jobvl || $jobvr){ |
3177
|
|
|
|
|
|
|
my ($sel, $job, $sdims); |
3178
|
|
|
|
|
|
|
unless ($jobvr && $jobvl){ |
3179
|
|
|
|
|
|
|
$job = $jobvl ? 2 : 1; |
3180
|
|
|
|
|
|
|
} |
3181
|
|
|
|
|
|
|
if ($select_func){ |
3182
|
|
|
|
|
|
|
if ($jobvl == 1 || $jobvr == 1 || $mult){ |
3183
|
|
|
|
|
|
|
$sdims = null; |
3184
|
|
|
|
|
|
|
if ($jobvl){ |
3185
|
|
|
|
|
|
|
if ($jobvsl){ |
3186
|
|
|
|
|
|
|
$vl = $vsl->copy; |
3187
|
|
|
|
|
|
|
} |
3188
|
|
|
|
|
|
|
else{ |
3189
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]); |
3190
|
|
|
|
|
|
|
$mult = 0; |
3191
|
|
|
|
|
|
|
} |
3192
|
|
|
|
|
|
|
} |
3193
|
|
|
|
|
|
|
if ($jobvr){ |
3194
|
|
|
|
|
|
|
if ($jobvsr){ |
3195
|
|
|
|
|
|
|
$vr = $vsr->copy; |
3196
|
|
|
|
|
|
|
} |
3197
|
|
|
|
|
|
|
else{ |
3198
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]); |
3199
|
|
|
|
|
|
|
$mult = 0; |
3200
|
|
|
|
|
|
|
} |
3201
|
|
|
|
|
|
|
} |
3202
|
|
|
|
|
|
|
$mm->ctgevc($job, $mult, $pp, $sel, $vl, $vr, $sdims, my $infos=null); |
3203
|
|
|
|
|
|
|
if ($jobvr){ |
3204
|
|
|
|
|
|
|
if ($norm){ |
3205
|
|
|
|
|
|
|
$ret{VR} = $jobvr == 2 ? magn_norm($vr(,,:($sdim-1)),1) : magn_norm($vr,1); |
3206
|
|
|
|
|
|
|
} |
3207
|
|
|
|
|
|
|
else{ |
3208
|
|
|
|
|
|
|
$ret{VR} = $jobvr == 2 ? $vr(,,:($sdim-1))->xchg(1,2)->sever : $vr->xchg(1,2)->sever; |
3209
|
|
|
|
|
|
|
} |
3210
|
|
|
|
|
|
|
} |
3211
|
|
|
|
|
|
|
if ($jobvl){ |
3212
|
|
|
|
|
|
|
if ($norm){ |
3213
|
|
|
|
|
|
|
$ret{VL} = $jobvl == 2 ? magn_norm($vl(,,:($sdim-1)),1) : magn_norm($vl,1); |
3214
|
|
|
|
|
|
|
} |
3215
|
|
|
|
|
|
|
else{ |
3216
|
|
|
|
|
|
|
$ret{VL} = $jobvl == 2 ? $vl(,,:($sdim-1))->xchg(1,2)->sever : $vl->xchg(1,2)->sever; |
3217
|
|
|
|
|
|
|
} |
3218
|
|
|
|
|
|
|
} |
3219
|
|
|
|
|
|
|
} |
3220
|
|
|
|
|
|
|
else{ |
3221
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2,$mdims[1], $sdim) if $jobvr; |
3222
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $sdim) if $jobvl; |
3223
|
|
|
|
|
|
|
$sel = zeroes($mdims[1]); |
3224
|
|
|
|
|
|
|
$sel(:($sdim-1)) .= 1; |
3225
|
|
|
|
|
|
|
$mm->ctgevc($job, 2, $pp, $sel, $vl, $vr, $sdim, my $infos=null); |
3226
|
|
|
|
|
|
|
if ($jobvl){ |
3227
|
|
|
|
|
|
|
$ret{VL} = $norm ? magn_norm($vl,1) : $vl->xchg(1,2)->sever; |
3228
|
|
|
|
|
|
|
} |
3229
|
|
|
|
|
|
|
if ($jobvr){ |
3230
|
|
|
|
|
|
|
$ret{VR} = $norm ? magn_norm($vr,1) : $vr->xchg(1,2)->sever; |
3231
|
|
|
|
|
|
|
} |
3232
|
|
|
|
|
|
|
} |
3233
|
|
|
|
|
|
|
} |
3234
|
|
|
|
|
|
|
else{ |
3235
|
|
|
|
|
|
|
if ($jobvl){ |
3236
|
|
|
|
|
|
|
if ($jobvsl){ |
3237
|
|
|
|
|
|
|
$vl = $vsl->copy; |
3238
|
|
|
|
|
|
|
} |
3239
|
|
|
|
|
|
|
else{ |
3240
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]); |
3241
|
|
|
|
|
|
|
$mult = 0; |
3242
|
|
|
|
|
|
|
} |
3243
|
|
|
|
|
|
|
} |
3244
|
|
|
|
|
|
|
if ($jobvr){ |
3245
|
|
|
|
|
|
|
if ($jobvsr){ |
3246
|
|
|
|
|
|
|
$vr = $vsr->copy; |
3247
|
|
|
|
|
|
|
} |
3248
|
|
|
|
|
|
|
else{ |
3249
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2, $mdims[1], $mdims[1]); |
3250
|
|
|
|
|
|
|
$mult = 0; |
3251
|
|
|
|
|
|
|
} |
3252
|
|
|
|
|
|
|
} |
3253
|
|
|
|
|
|
|
$mm->ctgevc($job, $mult, $pp,$sel, $vl, $vr, $sdim, my $infos=null); |
3254
|
|
|
|
|
|
|
if ($jobvl){ |
3255
|
|
|
|
|
|
|
$ret{VL} = $norm ? magn_norm($vl,1) : $vl->xchg(1,2)->sever; |
3256
|
|
|
|
|
|
|
} |
3257
|
|
|
|
|
|
|
if ($jobvr){ |
3258
|
|
|
|
|
|
|
$ret{VR} = $norm ? magn_norm($vr,1) : $vr->xchg(1,2)->sever; |
3259
|
|
|
|
|
|
|
} |
3260
|
|
|
|
|
|
|
} |
3261
|
|
|
|
|
|
|
} |
3262
|
|
|
|
|
|
|
if ($jobvsl == 2 && $select_func) { |
3263
|
|
|
|
|
|
|
$vsl = $sdim > 0 ? $vsl->xchg(1,2)->(,:($sdim-1),) ->sever : PDL::Complex->null; |
3264
|
|
|
|
|
|
|
$ret{SL} = $vsl; |
3265
|
|
|
|
|
|
|
} |
3266
|
|
|
|
|
|
|
elsif($jobvsl){ |
3267
|
|
|
|
|
|
|
$vsl = $vsl->xchg(1,2)->sever; |
3268
|
|
|
|
|
|
|
$ret{SL} = $vsl; |
3269
|
|
|
|
|
|
|
} |
3270
|
|
|
|
|
|
|
if ($jobvsr == 2 && $select_func) { |
3271
|
|
|
|
|
|
|
$vsr = $sdim > 0 ? $vsr->xchg(1,2)->(,:($sdim-1),) ->sever : PDL::Complex->null; |
3272
|
|
|
|
|
|
|
$ret{SR} = $vsr; |
3273
|
|
|
|
|
|
|
} |
3274
|
|
|
|
|
|
|
elsif($jobvsr){ |
3275
|
|
|
|
|
|
|
$vsr = $vsr->xchg(1,2)->sever; |
3276
|
|
|
|
|
|
|
$ret{SR} = $vsr; |
3277
|
|
|
|
|
|
|
} |
3278
|
|
|
|
|
|
|
} |
3279
|
|
|
|
|
|
|
else{ |
3280
|
|
|
|
|
|
|
my ($select_f, $wi, $wtmp); |
3281
|
|
|
|
|
|
|
if ($select_func){ |
3282
|
|
|
|
|
|
|
no strict 'refs'; |
3283
|
|
|
|
|
|
|
$select_f= sub{ |
3284
|
|
|
|
|
|
|
&$select_func(PDL::Complex::complex(pdl($type,$_[0],$_[1])), $_[2]); |
3285
|
|
|
|
|
|
|
}; |
3286
|
|
|
|
|
|
|
} |
3287
|
|
|
|
|
|
|
$wi = null; |
3288
|
|
|
|
|
|
|
$wtmp = null; |
3289
|
|
|
|
|
|
|
$beta = null; |
3290
|
|
|
|
|
|
|
#$vsl = $jobvsl ? PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]) : |
3291
|
|
|
|
|
|
|
# pdl($type,[[0]]); |
3292
|
|
|
|
|
|
|
$vsl = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]); |
3293
|
|
|
|
|
|
|
$vsr = $jobvsr ? PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]) : |
3294
|
|
|
|
|
|
|
pdl($type,[[0]]); |
3295
|
|
|
|
|
|
|
$mm->ggesx( $jobvsl, $jobvsr, $select, $sense, $pp, $wtmp, $wi, $beta, $vsl, $vsr, $sdim, $rconde, $rcondv,$info, $select_f); |
3296
|
|
|
|
|
|
|
if ($info){ |
3297
|
|
|
|
|
|
|
if ($info < $mdims[0]){ |
3298
|
|
|
|
|
|
|
laerror("mgschurx: The QZ algorithm failed to converge"); |
3299
|
|
|
|
|
|
|
print ("Returning converged eigenvalues\n") if $_laerror; |
3300
|
|
|
|
|
|
|
} |
3301
|
|
|
|
|
|
|
laerror("mgschurx: The eigenvalues could not be reordered because some\n". |
3302
|
|
|
|
|
|
|
"eigenvalues were too close to separate (the problem". |
3303
|
|
|
|
|
|
|
"is very ill-conditioned)") |
3304
|
|
|
|
|
|
|
if $info == ($mdims[0] + 3); |
3305
|
|
|
|
|
|
|
laerror("mgschurx: Error in hgeqz\n") |
3306
|
|
|
|
|
|
|
if $info == ($mdims[0] + 1); |
3307
|
|
|
|
|
|
|
|
3308
|
|
|
|
|
|
|
if ($info == ($mdims[0] + 2)){ |
3309
|
|
|
|
|
|
|
warn("mgschur: The Schur form no longer satisfy select_func = 1\n because of roundoff or underflow\n") if $_laerror; |
3310
|
|
|
|
|
|
|
$sdim+=1 if ($sdim < $mdims[0] && $wi($sdim) != 0 && $wi($sdim-1) == -$wi($sdim)); |
3311
|
|
|
|
|
|
|
} |
3312
|
|
|
|
|
|
|
} |
3313
|
|
|
|
|
|
|
|
3314
|
|
|
|
|
|
|
if ($select_func){ |
3315
|
|
|
|
|
|
|
if(!$sdim){ |
3316
|
|
|
|
|
|
|
if ($jobvl == 2){ |
3317
|
|
|
|
|
|
|
$ret{VL} = null; |
3318
|
|
|
|
|
|
|
$jobvl = 0; |
3319
|
|
|
|
|
|
|
} |
3320
|
|
|
|
|
|
|
if ($jobvr == 2){ |
3321
|
|
|
|
|
|
|
$ret{VR} = null; |
3322
|
|
|
|
|
|
|
$jobvr = 0; |
3323
|
|
|
|
|
|
|
} |
3324
|
|
|
|
|
|
|
} |
3325
|
|
|
|
|
|
|
$ret{n} = $sdim; |
3326
|
|
|
|
|
|
|
} |
3327
|
|
|
|
|
|
|
|
3328
|
|
|
|
|
|
|
if ($jobvl || $jobvr){ |
3329
|
|
|
|
|
|
|
my ($sel, $job, $wtmpi, $wtmpr, $sdims); |
3330
|
|
|
|
|
|
|
unless ($jobvr && $jobvl){ |
3331
|
|
|
|
|
|
|
$job = $jobvl ? 2 : 1; |
3332
|
|
|
|
|
|
|
} |
3333
|
|
|
|
|
|
|
if ($select_func){ |
3334
|
|
|
|
|
|
|
$sdims = null; |
3335
|
|
|
|
|
|
|
if ($jobvl == 1 || $jobvr == 1 || $mult){ |
3336
|
|
|
|
|
|
|
if ($jobvl){ |
3337
|
|
|
|
|
|
|
if ($jobvsl){ |
3338
|
|
|
|
|
|
|
$vl = $vsl->copy; |
3339
|
|
|
|
|
|
|
} |
3340
|
|
|
|
|
|
|
else{ |
3341
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]); |
3342
|
|
|
|
|
|
|
$mult = 0; |
3343
|
|
|
|
|
|
|
} |
3344
|
|
|
|
|
|
|
} |
3345
|
|
|
|
|
|
|
if ($jobvr){ |
3346
|
|
|
|
|
|
|
if ($jobvsr){ |
3347
|
|
|
|
|
|
|
$vr = $vsr->copy; |
3348
|
|
|
|
|
|
|
} |
3349
|
|
|
|
|
|
|
else{ |
3350
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]); |
3351
|
|
|
|
|
|
|
$mult = 0; |
3352
|
|
|
|
|
|
|
} |
3353
|
|
|
|
|
|
|
} |
3354
|
|
|
|
|
|
|
|
3355
|
|
|
|
|
|
|
$mm->tgevc($job, $mult, $pp, $sel, $vl, $vr, $sdims, my $infos=null); |
3356
|
|
|
|
|
|
|
if ($jobvr){ |
3357
|
|
|
|
|
|
|
if($norm){ |
3358
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); |
3359
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
3360
|
|
|
|
|
|
|
$ret{VR} = $jobvr == 2 ? magn_norm($vr(,,:($sdim-1)),1) : magn_norm($vr,1); |
3361
|
|
|
|
|
|
|
} |
3362
|
|
|
|
|
|
|
else{ |
3363
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); |
3364
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
3365
|
|
|
|
|
|
|
$ret{VR} = $jobvr == 2 ? $vr(,:($sdim-1))->sever : $vr; |
3366
|
|
|
|
|
|
|
} |
3367
|
|
|
|
|
|
|
} |
3368
|
|
|
|
|
|
|
if ($jobvl){ |
3369
|
|
|
|
|
|
|
if ($norm){ |
3370
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); |
3371
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
3372
|
|
|
|
|
|
|
$ret{VL} = $jobvl == 2 ? magn_norm($vl(,,:($sdim-1)),1) : magn_norm($vl,1); |
3373
|
|
|
|
|
|
|
} |
3374
|
|
|
|
|
|
|
else{ |
3375
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); |
3376
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
3377
|
|
|
|
|
|
|
$ret{VL} = $jobvl == 2 ? $vl(,:($sdim-1))->sever : $vl; |
3378
|
|
|
|
|
|
|
} |
3379
|
|
|
|
|
|
|
} |
3380
|
|
|
|
|
|
|
} |
3381
|
|
|
|
|
|
|
else{ |
3382
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $mdims[1], $sdim) if $jobvr; |
3383
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $mdims[1], $sdim) if $jobvl; |
3384
|
|
|
|
|
|
|
$sel = zeroes($mdims[1]); |
3385
|
|
|
|
|
|
|
$sel(:($sdim-1)) .= 1; |
3386
|
|
|
|
|
|
|
$mm->tgevc($job, 2, $pp, $sel, $vl, $vr, $sdim, my $infos = null); |
3387
|
|
|
|
|
|
|
$wtmpr = $wtmp(:($sdim-1)); |
3388
|
|
|
|
|
|
|
$wtmpi = $wi(:($sdim-1)); |
3389
|
|
|
|
|
|
|
if ($jobvr){ |
3390
|
|
|
|
|
|
|
if ($norm){ |
3391
|
|
|
|
|
|
|
(undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr,1); |
3392
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
3393
|
|
|
|
|
|
|
$ret{VR} = magn_norm($vr,1); |
3394
|
|
|
|
|
|
|
} |
3395
|
|
|
|
|
|
|
else{ |
3396
|
|
|
|
|
|
|
(undef,$vr) = $wtmpr->cplx_eigen($wtmpi,$vr->xchg(0,1),0); |
3397
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
3398
|
|
|
|
|
|
|
$ret{VR} = $vr; |
3399
|
|
|
|
|
|
|
} |
3400
|
|
|
|
|
|
|
} |
3401
|
|
|
|
|
|
|
if ($jobvl){ |
3402
|
|
|
|
|
|
|
if ($norm){ |
3403
|
|
|
|
|
|
|
(undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl,1); |
3404
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
3405
|
|
|
|
|
|
|
$ret{VL} = magn_norm($vl,1); |
3406
|
|
|
|
|
|
|
} |
3407
|
|
|
|
|
|
|
else{ |
3408
|
|
|
|
|
|
|
(undef,$vl) = $wtmpr->cplx_eigen($wtmpi,$vl->xchg(0,1),0); |
3409
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
3410
|
|
|
|
|
|
|
$ret{VL} = $vl; |
3411
|
|
|
|
|
|
|
} |
3412
|
|
|
|
|
|
|
} |
3413
|
|
|
|
|
|
|
} |
3414
|
|
|
|
|
|
|
} |
3415
|
|
|
|
|
|
|
else{ |
3416
|
|
|
|
|
|
|
if ($jobvl){ |
3417
|
|
|
|
|
|
|
if ($jobvsl){ |
3418
|
|
|
|
|
|
|
$vl = $vsl->copy; |
3419
|
|
|
|
|
|
|
} |
3420
|
|
|
|
|
|
|
else{ |
3421
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]); |
3422
|
|
|
|
|
|
|
$mult = 0; |
3423
|
|
|
|
|
|
|
} |
3424
|
|
|
|
|
|
|
} |
3425
|
|
|
|
|
|
|
if ($jobvr){ |
3426
|
|
|
|
|
|
|
if ($jobvsr){ |
3427
|
|
|
|
|
|
|
$vr = $vsr->copy; |
3428
|
|
|
|
|
|
|
} |
3429
|
|
|
|
|
|
|
else{ |
3430
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $mdims[1], $mdims[1]); |
3431
|
|
|
|
|
|
|
$mult = 0; |
3432
|
|
|
|
|
|
|
} |
3433
|
|
|
|
|
|
|
} |
3434
|
|
|
|
|
|
|
|
3435
|
|
|
|
|
|
|
$mm->tgevc($job, $mult, $pp, $sel, $vl, $vr, $sdim, my $infos=null); |
3436
|
|
|
|
|
|
|
if ($jobvl){ |
3437
|
|
|
|
|
|
|
if ($norm){ |
3438
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl,1); |
3439
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
3440
|
|
|
|
|
|
|
$ret{VL} = magn_norm($vl,1); |
3441
|
|
|
|
|
|
|
} |
3442
|
|
|
|
|
|
|
else{ |
3443
|
|
|
|
|
|
|
(undef,$vl) = $wtmp->cplx_eigen($wi,$vl->xchg(0,1),0); |
3444
|
|
|
|
|
|
|
bless $vl, 'PDL::Complex'; |
3445
|
|
|
|
|
|
|
$ret{VL} = $vl; |
3446
|
|
|
|
|
|
|
} |
3447
|
|
|
|
|
|
|
} |
3448
|
|
|
|
|
|
|
if ($jobvr){ |
3449
|
|
|
|
|
|
|
if ($norm){ |
3450
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr,1); |
3451
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
3452
|
|
|
|
|
|
|
$ret{VR} = magn_norm($vr,1); |
3453
|
|
|
|
|
|
|
} |
3454
|
|
|
|
|
|
|
else{ |
3455
|
|
|
|
|
|
|
(undef,$vr) = $wtmp->cplx_eigen($wi,$vr->xchg(0,1),0); |
3456
|
|
|
|
|
|
|
bless $vr, 'PDL::Complex'; |
3457
|
|
|
|
|
|
|
$ret{VR} = $vr; |
3458
|
|
|
|
|
|
|
} |
3459
|
|
|
|
|
|
|
} |
3460
|
|
|
|
|
|
|
} |
3461
|
|
|
|
|
|
|
} |
3462
|
|
|
|
|
|
|
$w = PDL::Complex::ecplx ($wtmp, $wi); |
3463
|
|
|
|
|
|
|
|
3464
|
|
|
|
|
|
|
if ($jobvsr == 2 && $select_func) { |
3465
|
|
|
|
|
|
|
$vsr = $sdim > 0 ? $vsr->xchg(0,1)->(:($sdim-1),) ->sever : null; |
3466
|
|
|
|
|
|
|
$ret{SR} = $vsr; |
3467
|
|
|
|
|
|
|
} |
3468
|
|
|
|
|
|
|
elsif($jobvsr){ |
3469
|
|
|
|
|
|
|
$vsr = $vsr->xchg(0,1)->sever; |
3470
|
|
|
|
|
|
|
$ret{SR} = $vsr; |
3471
|
|
|
|
|
|
|
} |
3472
|
|
|
|
|
|
|
|
3473
|
|
|
|
|
|
|
if ($jobvsl == 2 && $select_func) { |
3474
|
|
|
|
|
|
|
$vsl = $sdim > 0 ? $vsl->xchg(0,1)->(:($sdim-1),) ->sever : null; |
3475
|
|
|
|
|
|
|
$ret{SL} = $vsl; |
3476
|
|
|
|
|
|
|
} |
3477
|
|
|
|
|
|
|
elsif($jobvsl){ |
3478
|
|
|
|
|
|
|
$vsl = $vsl->xchg(0,1)->sever; |
3479
|
|
|
|
|
|
|
$ret{SL} = $vsl; |
3480
|
|
|
|
|
|
|
} |
3481
|
|
|
|
|
|
|
|
3482
|
|
|
|
|
|
|
} |
3483
|
|
|
|
|
|
|
|
3484
|
|
|
|
|
|
|
|
3485
|
|
|
|
|
|
|
$ret{info} = $info; |
3486
|
|
|
|
|
|
|
if ($sense){ |
3487
|
|
|
|
|
|
|
if ($sense == 3){ |
3488
|
|
|
|
|
|
|
$ret{rconde} = $rconde; |
3489
|
|
|
|
|
|
|
$ret{rcondv} = $rcondv; |
3490
|
|
|
|
|
|
|
} |
3491
|
|
|
|
|
|
|
else{ |
3492
|
|
|
|
|
|
|
$ret{rconde} = $rconde if ($sense == 1); |
3493
|
|
|
|
|
|
|
$ret{rcondv} = $rcondv if ($sense == 2); |
3494
|
|
|
|
|
|
|
} |
3495
|
|
|
|
|
|
|
} |
3496
|
|
|
|
|
|
|
$m = $mm->xchg(-1,-2)->sever unless $m->is_inplace(0); |
3497
|
|
|
|
|
|
|
$p = $pp->xchg(-1,-2)->sever unless $p->is_inplace(0); |
3498
|
|
|
|
|
|
|
return ($m, $p, $w, $beta, %ret); |
3499
|
|
|
|
|
|
|
} |
3500
|
|
|
|
|
|
|
|
3501
|
|
|
|
|
|
|
|
3502
|
|
|
|
|
|
|
=head2 mqr |
3503
|
|
|
|
|
|
|
|
3504
|
|
|
|
|
|
|
=for ref |
3505
|
|
|
|
|
|
|
|
3506
|
|
|
|
|
|
|
Computes QR decomposition. |
3507
|
|
|
|
|
|
|
For complex number needs object of type PDL::Complex. |
3508
|
|
|
|
|
|
|
Uses L and L |
3509
|
|
|
|
|
|
|
or L and L |
3510
|
|
|
|
|
|
|
from Lapack and returns C in scalar context. Works on transposed array. |
3511
|
|
|
|
|
|
|
|
3512
|
|
|
|
|
|
|
=for usage |
3513
|
|
|
|
|
|
|
|
3514
|
|
|
|
|
|
|
(PDL(Q), PDL(R), PDL(info)) = mqr(PDL, SCALAR) |
3515
|
|
|
|
|
|
|
SCALAR : ECONOMIC = 0 | FULL = 1, default = 0 |
3516
|
|
|
|
|
|
|
|
3517
|
|
|
|
|
|
|
=for example |
3518
|
|
|
|
|
|
|
|
3519
|
|
|
|
|
|
|
my $a = random(10,10); |
3520
|
|
|
|
|
|
|
my ( $q, $r ) = mqr($a); |
3521
|
|
|
|
|
|
|
# Can compute full decomposition if nrow > ncol |
3522
|
|
|
|
|
|
|
$a = random(5,7); |
3523
|
|
|
|
|
|
|
( $q, $r ) = $a->mqr(1); |
3524
|
|
|
|
|
|
|
|
3525
|
|
|
|
|
|
|
=cut |
3526
|
|
|
|
|
|
|
|
3527
|
|
|
|
|
|
|
sub mqr{ |
3528
|
|
|
|
|
|
|
my $m = shift; |
3529
|
|
|
|
|
|
|
$m->mqr(@_); |
3530
|
|
|
|
|
|
|
} |
3531
|
|
|
|
|
|
|
|
3532
|
|
|
|
|
|
|
sub PDL::mqr { |
3533
|
|
|
|
|
|
|
my($m, $full) = @_; |
3534
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
3535
|
|
|
|
|
|
|
my ($q, $r); |
3536
|
|
|
|
|
|
|
barf("mqr: Require a matrix") unless @dims == 2; |
3537
|
|
|
|
|
|
|
|
3538
|
|
|
|
|
|
|
$m = $m->xchg(0,1)->copy; |
3539
|
|
|
|
|
|
|
my $min = $dims[0] < $dims[1] ? $dims[0] : $dims[1]; |
3540
|
|
|
|
|
|
|
|
3541
|
|
|
|
|
|
|
my $tau = zeroes($m->type, $min); |
3542
|
|
|
|
|
|
|
$m->geqrf($tau, (my $info = pdl(long,0))); |
3543
|
|
|
|
|
|
|
if ($info){ |
3544
|
|
|
|
|
|
|
laerror("mqr: Error $info in geqrf\n"); |
3545
|
|
|
|
|
|
|
$q = $r = $m; |
3546
|
|
|
|
|
|
|
} |
3547
|
|
|
|
|
|
|
else{ |
3548
|
|
|
|
|
|
|
$q = $dims[0] > $dims[1] ? $m(:,:($min-1))->copy : $m->copy; |
3549
|
|
|
|
|
|
|
$q->reshape($dims[1], $dims[1]) if $full && $dims[0] < $dims[1]; |
3550
|
|
|
|
|
|
|
|
3551
|
|
|
|
|
|
|
$q->orgqr($tau, $info); |
3552
|
|
|
|
|
|
|
return $q->xchg(0,1)->sever unless wantarray; |
3553
|
|
|
|
|
|
|
|
3554
|
|
|
|
|
|
|
if ($dims[0] < $dims[1] && !$full){ |
3555
|
|
|
|
|
|
|
$r = zeroes($m->type, $min, $min); |
3556
|
|
|
|
|
|
|
$m->xchg(0,1)->(,:($min-1))->tricpy(0,$r); |
3557
|
|
|
|
|
|
|
} |
3558
|
|
|
|
|
|
|
else{ |
3559
|
|
|
|
|
|
|
$r = zeroes($m->type, $dims[0],$dims[1]); |
3560
|
|
|
|
|
|
|
$m->xchg(0,1)->tricpy(0,$r); |
3561
|
|
|
|
|
|
|
} |
3562
|
|
|
|
|
|
|
} |
3563
|
|
|
|
|
|
|
return ($q->xchg(0,1)->sever, $r, $info); |
3564
|
|
|
|
|
|
|
} |
3565
|
|
|
|
|
|
|
|
3566
|
|
|
|
|
|
|
sub PDL::Complex::mqr { |
3567
|
|
|
|
|
|
|
my($m, $full) = @_; |
3568
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
3569
|
|
|
|
|
|
|
my ($q, $r); |
3570
|
|
|
|
|
|
|
barf("mqr: Require a matrix") unless @dims == 3; |
3571
|
|
|
|
|
|
|
|
3572
|
|
|
|
|
|
|
$m = $m->xchg(1,2)->copy; |
3573
|
|
|
|
|
|
|
my $min = $dims[1] < $dims[2] ? $dims[1] : $dims[2]; |
3574
|
|
|
|
|
|
|
|
3575
|
|
|
|
|
|
|
my $tau = zeroes($m->type, 2, $min); |
3576
|
|
|
|
|
|
|
$m->cgeqrf($tau, (my $info = pdl(long,0))); |
3577
|
|
|
|
|
|
|
if ($info){ |
3578
|
|
|
|
|
|
|
laerror("mqr: Error $info in cgeqrf\n"); |
3579
|
|
|
|
|
|
|
$q = $r = $m; |
3580
|
|
|
|
|
|
|
} |
3581
|
|
|
|
|
|
|
else{ |
3582
|
|
|
|
|
|
|
$q = $dims[1] > $dims[2] ? $m(,:,:($min-1))->copy : $m->copy; |
3583
|
|
|
|
|
|
|
$q->reshape(2,$dims[2], $dims[2]) if $full && $dims[1] < $dims[2]; |
3584
|
|
|
|
|
|
|
|
3585
|
|
|
|
|
|
|
$q->cungqr($tau, $info); |
3586
|
|
|
|
|
|
|
return $q->xchg(1,2)->sever unless wantarray; |
3587
|
|
|
|
|
|
|
|
3588
|
|
|
|
|
|
|
if ($dims[1] < $dims[2] && !$full){ |
3589
|
|
|
|
|
|
|
$r = PDL::new_from_specification('PDL::Complex',$m->type, 2, $min, $min); |
3590
|
|
|
|
|
|
|
$r .= 0; |
3591
|
|
|
|
|
|
|
$m->xchg(1,2)->(,,:($min-1))->ctricpy(0,$r); |
3592
|
|
|
|
|
|
|
} |
3593
|
|
|
|
|
|
|
else{ |
3594
|
|
|
|
|
|
|
$r = PDL::new_from_specification('PDL::Complex', $m->type, 2, $dims[1],$dims[2]); |
3595
|
|
|
|
|
|
|
$r .= 0; |
3596
|
|
|
|
|
|
|
$m->xchg(1,2)->ctricpy(0,$r); |
3597
|
|
|
|
|
|
|
} |
3598
|
|
|
|
|
|
|
} |
3599
|
|
|
|
|
|
|
return ($q->xchg(1,2)->sever, $r, $info); |
3600
|
|
|
|
|
|
|
} |
3601
|
|
|
|
|
|
|
|
3602
|
|
|
|
|
|
|
=head2 mrq |
3603
|
|
|
|
|
|
|
|
3604
|
|
|
|
|
|
|
=for ref |
3605
|
|
|
|
|
|
|
|
3606
|
|
|
|
|
|
|
Computes RQ decomposition. |
3607
|
|
|
|
|
|
|
For complex number needs object of type PDL::Complex. |
3608
|
|
|
|
|
|
|
Uses L and L |
3609
|
|
|
|
|
|
|
or L and L |
3610
|
|
|
|
|
|
|
from Lapack and returns C in scalar context. Works on transposed array. |
3611
|
|
|
|
|
|
|
|
3612
|
|
|
|
|
|
|
=for usage |
3613
|
|
|
|
|
|
|
|
3614
|
|
|
|
|
|
|
(PDL(R), PDL(Q), PDL(info)) = mrq(PDL, SCALAR) |
3615
|
|
|
|
|
|
|
SCALAR : ECONOMIC = 0 | FULL = 1, default = 0 |
3616
|
|
|
|
|
|
|
|
3617
|
|
|
|
|
|
|
=for example |
3618
|
|
|
|
|
|
|
|
3619
|
|
|
|
|
|
|
my $a = random(10,10); |
3620
|
|
|
|
|
|
|
my ( $r, $q ) = mrq($a); |
3621
|
|
|
|
|
|
|
# Can compute full decomposition if nrow < ncol |
3622
|
|
|
|
|
|
|
$a = random(5,7); |
3623
|
|
|
|
|
|
|
( $r, $q ) = $a->mrq(1); |
3624
|
|
|
|
|
|
|
|
3625
|
|
|
|
|
|
|
=cut |
3626
|
|
|
|
|
|
|
|
3627
|
|
|
|
|
|
|
sub mrq{ |
3628
|
|
|
|
|
|
|
my $m = shift; |
3629
|
|
|
|
|
|
|
$m->mrq(@_); |
3630
|
|
|
|
|
|
|
} |
3631
|
|
|
|
|
|
|
|
3632
|
|
|
|
|
|
|
sub PDL::mrq { |
3633
|
|
|
|
|
|
|
my($m, $full) = @_; |
3634
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
3635
|
|
|
|
|
|
|
my ($q, $r); |
3636
|
|
|
|
|
|
|
|
3637
|
|
|
|
|
|
|
|
3638
|
|
|
|
|
|
|
barf("mrq: Require a matrix") unless @dims == 2; |
3639
|
|
|
|
|
|
|
$m = $m->xchg(0,1)->copy; |
3640
|
|
|
|
|
|
|
my $min = $dims[0] < $dims[1] ? $dims[0] : $dims[1]; |
3641
|
|
|
|
|
|
|
|
3642
|
|
|
|
|
|
|
my $tau = zeroes($m->type, $min); |
3643
|
|
|
|
|
|
|
$m->gerqf($tau, (my $info = pdl(long,0))); |
3644
|
|
|
|
|
|
|
if ($info){ |
3645
|
|
|
|
|
|
|
laerror ("mrq: Error $info in gerqf\n"); |
3646
|
|
|
|
|
|
|
$r = $q = $m; |
3647
|
|
|
|
|
|
|
} |
3648
|
|
|
|
|
|
|
else{ |
3649
|
|
|
|
|
|
|
if ($dims[0] > $dims[1] && $full){ |
3650
|
|
|
|
|
|
|
$q = zeroes($m->type, $dims[0],$dims[0]); |
3651
|
|
|
|
|
|
|
$q(($dims[0] - $dims[1]):,:) .= $m; |
3652
|
|
|
|
|
|
|
} |
3653
|
|
|
|
|
|
|
elsif ($dims[0] < $dims[1]){ |
3654
|
|
|
|
|
|
|
$q = $m(($dims[1] - $dims[0]):,:)->copy; |
3655
|
|
|
|
|
|
|
} |
3656
|
|
|
|
|
|
|
else{ |
3657
|
|
|
|
|
|
|
$q = $m->copy; |
3658
|
|
|
|
|
|
|
} |
3659
|
|
|
|
|
|
|
|
3660
|
|
|
|
|
|
|
$q->orgrq($tau, $info); |
3661
|
|
|
|
|
|
|
return $q->xchg(0,1)->sever unless wantarray; |
3662
|
|
|
|
|
|
|
|
3663
|
|
|
|
|
|
|
if ($dims[0] > $dims[1] && $full){ |
3664
|
|
|
|
|
|
|
$r = zeroes ($m->type,$dims[0],$dims[1]); |
3665
|
|
|
|
|
|
|
$m->xchg(0,1)->tricpy(0,$r); |
3666
|
|
|
|
|
|
|
$r(:($min-1),:($min-1))->diagonal(0,1) .= 0; |
3667
|
|
|
|
|
|
|
} |
3668
|
|
|
|
|
|
|
elsif ($dims[0] < $dims[1]){ |
3669
|
|
|
|
|
|
|
my $temp = zeroes($m->type,$dims[1],$dims[1]); |
3670
|
|
|
|
|
|
|
$temp(-$min:, :) .= $m->xchg(0,1)->sever; |
3671
|
|
|
|
|
|
|
$r = PDL::zeroes($temp); |
3672
|
|
|
|
|
|
|
$temp->tricpy(0,$r); |
3673
|
|
|
|
|
|
|
$r = $r(-$min:, :); |
3674
|
|
|
|
|
|
|
} |
3675
|
|
|
|
|
|
|
else{ |
3676
|
|
|
|
|
|
|
$r = zeroes($m->type, $min, $min); |
3677
|
|
|
|
|
|
|
$m->xchg(0,1)->(($dims[0] - $dims[1]):, :)->tricpy(0,$r); |
3678
|
|
|
|
|
|
|
} |
3679
|
|
|
|
|
|
|
} |
3680
|
|
|
|
|
|
|
return ($r, $q->xchg(0,1)->sever, $info); |
3681
|
|
|
|
|
|
|
|
3682
|
|
|
|
|
|
|
} |
3683
|
|
|
|
|
|
|
|
3684
|
|
|
|
|
|
|
sub PDL::Complex::mrq { |
3685
|
|
|
|
|
|
|
my($m, $full) = @_; |
3686
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
3687
|
|
|
|
|
|
|
my ($q, $r); |
3688
|
|
|
|
|
|
|
|
3689
|
|
|
|
|
|
|
|
3690
|
|
|
|
|
|
|
barf("mrq: Require a matrix") unless @dims == 3; |
3691
|
|
|
|
|
|
|
$m = $m->xchg(1,2)->copy; |
3692
|
|
|
|
|
|
|
my $min = $dims[1] < $dims[2] ? $dims[1] : $dims[2]; |
3693
|
|
|
|
|
|
|
|
3694
|
|
|
|
|
|
|
my $tau = zeroes($m->type, 2, $min); |
3695
|
|
|
|
|
|
|
$m->cgerqf($tau, (my $info = pdl(long,0))); |
3696
|
|
|
|
|
|
|
if ($info){ |
3697
|
|
|
|
|
|
|
laerror ("mrq: Error $info in cgerqf\n"); |
3698
|
|
|
|
|
|
|
$r = $q = $m; |
3699
|
|
|
|
|
|
|
} |
3700
|
|
|
|
|
|
|
else{ |
3701
|
|
|
|
|
|
|
if ($dims[1] > $dims[2] && $full){ |
3702
|
|
|
|
|
|
|
$q = PDL::new_from_specification('PDL::Complex',$m->type, 2, $dims[1],$dims[1]); |
3703
|
|
|
|
|
|
|
$q .= 0; |
3704
|
|
|
|
|
|
|
$q(,($dims[1] - $dims[2]):,:) .= $m; |
3705
|
|
|
|
|
|
|
} |
3706
|
|
|
|
|
|
|
elsif ($dims[1] < $dims[2]){ |
3707
|
|
|
|
|
|
|
$q = $m(,($dims[2] - $dims[1]):,:)->copy; |
3708
|
|
|
|
|
|
|
} |
3709
|
|
|
|
|
|
|
else{ |
3710
|
|
|
|
|
|
|
$q = $m->copy; |
3711
|
|
|
|
|
|
|
} |
3712
|
|
|
|
|
|
|
|
3713
|
|
|
|
|
|
|
$q->cungrq($tau, $info); |
3714
|
|
|
|
|
|
|
return $q->xchg(1,2)->sever unless wantarray; |
3715
|
|
|
|
|
|
|
|
3716
|
|
|
|
|
|
|
if ($dims[1] > $dims[2] && $full){ |
3717
|
|
|
|
|
|
|
$r = PDL::new_from_specification('PDL::Complex',$m->type,2,$dims[1],$dims[2]); |
3718
|
|
|
|
|
|
|
$r .= 0; |
3719
|
|
|
|
|
|
|
$m->xchg(1,2)->ctricpy(0,$r); |
3720
|
|
|
|
|
|
|
$r(,:($min-1),:($min-1))->diagonal(1,2) .= 0; |
3721
|
|
|
|
|
|
|
} |
3722
|
|
|
|
|
|
|
elsif ($dims[1] < $dims[2]){ |
3723
|
|
|
|
|
|
|
my $temp = PDL::new_from_specification('PDL::Complex',$m->type,2,$dims[2],$dims[2]); |
3724
|
|
|
|
|
|
|
$temp .= 0; |
3725
|
|
|
|
|
|
|
$temp(,-$min:, :) .= $m->xchg(1,2); |
3726
|
|
|
|
|
|
|
$r = PDL::zeroes($temp); |
3727
|
|
|
|
|
|
|
$temp->ctricpy(0,$r); |
3728
|
|
|
|
|
|
|
$r = $r(,-$min:, :)->sever; |
3729
|
|
|
|
|
|
|
} |
3730
|
|
|
|
|
|
|
else{ |
3731
|
|
|
|
|
|
|
$r = PDL::new_from_specification('PDL::Complex',$m->type, 2,$min, $min); |
3732
|
|
|
|
|
|
|
$r .= 0; |
3733
|
|
|
|
|
|
|
$m->xchg(1,2)->(,($dims[1] - $dims[2]):, :)->ctricpy(0,$r); |
3734
|
|
|
|
|
|
|
} |
3735
|
|
|
|
|
|
|
} |
3736
|
|
|
|
|
|
|
return ($r, $q->xchg(1,2)->sever, $info); |
3737
|
|
|
|
|
|
|
|
3738
|
|
|
|
|
|
|
} |
3739
|
|
|
|
|
|
|
|
3740
|
|
|
|
|
|
|
=head2 mql |
3741
|
|
|
|
|
|
|
|
3742
|
|
|
|
|
|
|
=for ref |
3743
|
|
|
|
|
|
|
|
3744
|
|
|
|
|
|
|
Computes QL decomposition. |
3745
|
|
|
|
|
|
|
For complex number needs object of type PDL::Complex. |
3746
|
|
|
|
|
|
|
Uses L and L |
3747
|
|
|
|
|
|
|
or L and L |
3748
|
|
|
|
|
|
|
from Lapack and returns C in scalar context. Works on transposed array. |
3749
|
|
|
|
|
|
|
|
3750
|
|
|
|
|
|
|
=for usage |
3751
|
|
|
|
|
|
|
|
3752
|
|
|
|
|
|
|
(PDL(Q), PDL(L), PDL(info)) = mql(PDL, SCALAR) |
3753
|
|
|
|
|
|
|
SCALAR : ECONOMIC = 0 | FULL = 1, default = 0 |
3754
|
|
|
|
|
|
|
|
3755
|
|
|
|
|
|
|
=for example |
3756
|
|
|
|
|
|
|
|
3757
|
|
|
|
|
|
|
my $a = random(10,10); |
3758
|
|
|
|
|
|
|
my ( $q, $l ) = mql($a); |
3759
|
|
|
|
|
|
|
# Can compute full decomposition if nrow > ncol |
3760
|
|
|
|
|
|
|
$a = random(5,7); |
3761
|
|
|
|
|
|
|
( $q, $l ) = $a->mql(1); |
3762
|
|
|
|
|
|
|
|
3763
|
|
|
|
|
|
|
=cut |
3764
|
|
|
|
|
|
|
|
3765
|
|
|
|
|
|
|
sub mql{ |
3766
|
|
|
|
|
|
|
my $m = shift; |
3767
|
|
|
|
|
|
|
$m->mql(@_); |
3768
|
|
|
|
|
|
|
} |
3769
|
|
|
|
|
|
|
|
3770
|
|
|
|
|
|
|
sub PDL::mql { |
3771
|
|
|
|
|
|
|
my($m, $full) = @_; |
3772
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
3773
|
|
|
|
|
|
|
my ($q, $l); |
3774
|
|
|
|
|
|
|
|
3775
|
|
|
|
|
|
|
|
3776
|
|
|
|
|
|
|
barf("mql: Require a matrix") unless @dims == 2; |
3777
|
|
|
|
|
|
|
$m = $m->xchg(0,1)->copy; |
3778
|
|
|
|
|
|
|
my $min = $dims[0] < $dims[1] ? $dims[0] : $dims[1]; |
3779
|
|
|
|
|
|
|
|
3780
|
|
|
|
|
|
|
my $tau = zeroes($m->type, $min); |
3781
|
|
|
|
|
|
|
$m->geqlf($tau, (my $info = pdl(long,0))); |
3782
|
|
|
|
|
|
|
if ($info){ |
3783
|
|
|
|
|
|
|
laerror("mql: Error $info in geqlf\n"); |
3784
|
|
|
|
|
|
|
$q = $l = $m; |
3785
|
|
|
|
|
|
|
} |
3786
|
|
|
|
|
|
|
else{ |
3787
|
|
|
|
|
|
|
if ($dims[0] < $dims[1] && $full){ |
3788
|
|
|
|
|
|
|
$q = zeroes($m->type, $dims[1],$dims[1]); |
3789
|
|
|
|
|
|
|
$q(:, -$dims[0]:) .= $m; |
3790
|
|
|
|
|
|
|
} |
3791
|
|
|
|
|
|
|
elsif ($dims[0] > $dims[1]){ |
3792
|
|
|
|
|
|
|
$q = $m(:,-$min:)->copy; |
3793
|
|
|
|
|
|
|
} |
3794
|
|
|
|
|
|
|
else{ |
3795
|
|
|
|
|
|
|
$q = $m->copy; |
3796
|
|
|
|
|
|
|
} |
3797
|
|
|
|
|
|
|
|
3798
|
|
|
|
|
|
|
$q->orgql($tau, $info); |
3799
|
|
|
|
|
|
|
return $q->xchg(0,1)->sever unless wantarray; |
3800
|
|
|
|
|
|
|
|
3801
|
|
|
|
|
|
|
if ($dims[0] < $dims[1] && $full){ |
3802
|
|
|
|
|
|
|
$l = zeroes ($m->type,$dims[0],$dims[1]); |
3803
|
|
|
|
|
|
|
$m->xchg(0,1)->tricpy(1,$l); |
3804
|
|
|
|
|
|
|
$l(:($min-1),:($min-1))->diagonal(0,1) .= 0; |
3805
|
|
|
|
|
|
|
} |
3806
|
|
|
|
|
|
|
elsif ($dims[0] > $dims[1]){ |
3807
|
|
|
|
|
|
|
my $temp = zeroes($m->type,$dims[0],$dims[0]); |
3808
|
|
|
|
|
|
|
$temp(:, -$dims[1]:) .= $m->xchg(0,1); |
3809
|
|
|
|
|
|
|
$l = PDL::zeroes($temp); |
3810
|
|
|
|
|
|
|
$temp->tricpy(1,$l); |
3811
|
|
|
|
|
|
|
$l = $l(:, -$dims[1]:)->sever; |
3812
|
|
|
|
|
|
|
} |
3813
|
|
|
|
|
|
|
else{ |
3814
|
|
|
|
|
|
|
$l = zeroes($m->type, $min, $min); |
3815
|
|
|
|
|
|
|
$m->xchg(0,1)->(:,($dims[1]-$min):)->tricpy(1,$l); |
3816
|
|
|
|
|
|
|
} |
3817
|
|
|
|
|
|
|
} |
3818
|
|
|
|
|
|
|
return ($q->xchg(0,1)->sever, $l, $info); |
3819
|
|
|
|
|
|
|
|
3820
|
|
|
|
|
|
|
} |
3821
|
|
|
|
|
|
|
|
3822
|
|
|
|
|
|
|
sub PDL::Complex::mql{ |
3823
|
|
|
|
|
|
|
my($m, $full) = @_; |
3824
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
3825
|
|
|
|
|
|
|
my ($q, $l); |
3826
|
|
|
|
|
|
|
|
3827
|
|
|
|
|
|
|
|
3828
|
|
|
|
|
|
|
barf("mql: Require a matrix") unless @dims == 3; |
3829
|
|
|
|
|
|
|
$m = $m->xchg(1,2)->copy; |
3830
|
|
|
|
|
|
|
my $min = $dims[1] < $dims[2] ? $dims[1] : $dims[2]; |
3831
|
|
|
|
|
|
|
|
3832
|
|
|
|
|
|
|
my $tau = zeroes($m->type, 2, $min); |
3833
|
|
|
|
|
|
|
$m->cgeqlf($tau, (my $info = pdl(long,0))); |
3834
|
|
|
|
|
|
|
if ($info){ |
3835
|
|
|
|
|
|
|
laerror("mql: Error $info in cgeqlf\n"); |
3836
|
|
|
|
|
|
|
$q = $l = $m; |
3837
|
|
|
|
|
|
|
} |
3838
|
|
|
|
|
|
|
else{ |
3839
|
|
|
|
|
|
|
if ($dims[1] < $dims[2] && $full){ |
3840
|
|
|
|
|
|
|
$q = PDL::new_from_specification('PDL::Complex', $m->type, 2, $dims[2],$dims[2]); |
3841
|
|
|
|
|
|
|
$q .= 0; |
3842
|
|
|
|
|
|
|
$q(,:, -$dims[1]:) .= $m; |
3843
|
|
|
|
|
|
|
} |
3844
|
|
|
|
|
|
|
elsif ($dims[1] > $dims[2]){ |
3845
|
|
|
|
|
|
|
$q = $m(,:,-$min:)->copy; |
3846
|
|
|
|
|
|
|
} |
3847
|
|
|
|
|
|
|
else{ |
3848
|
|
|
|
|
|
|
$q = $m->copy; |
3849
|
|
|
|
|
|
|
} |
3850
|
|
|
|
|
|
|
|
3851
|
|
|
|
|
|
|
$q->cungql($tau, $info); |
3852
|
|
|
|
|
|
|
return $q->xchg(1,2)->sever unless wantarray; |
3853
|
|
|
|
|
|
|
|
3854
|
|
|
|
|
|
|
if ($dims[1] < $dims[2] && $full){ |
3855
|
|
|
|
|
|
|
$l = PDL::new_from_specification('PDL::Complex', $m->type, 2, $dims[1], $dims[2]); |
3856
|
|
|
|
|
|
|
$l .= 0; |
3857
|
|
|
|
|
|
|
$m->xchg(1,2)->ctricpy(1,$l); |
3858
|
|
|
|
|
|
|
$l(,:($min-1),:($min-1))->diagonal(1,2) .= 0; |
3859
|
|
|
|
|
|
|
} |
3860
|
|
|
|
|
|
|
elsif ($dims[1] > $dims[2]){ |
3861
|
|
|
|
|
|
|
my $temp = PDL::new_from_specification('PDL::Complex',$m->type,2,$dims[1],$dims[1]); |
3862
|
|
|
|
|
|
|
$temp .= 0; |
3863
|
|
|
|
|
|
|
$temp(,, -$dims[2]:) .= $m->xchg(1,2); |
3864
|
|
|
|
|
|
|
$l = PDL::zeroes($temp); |
3865
|
|
|
|
|
|
|
$temp->ctricpy(1,$l); |
3866
|
|
|
|
|
|
|
$l = $l(,, -$dims[2]:)->sever; |
3867
|
|
|
|
|
|
|
} |
3868
|
|
|
|
|
|
|
else{ |
3869
|
|
|
|
|
|
|
$l = PDL::new_from_specification('PDL::Complex',$m->type, 2, $min, $min); |
3870
|
|
|
|
|
|
|
$l .= 0; |
3871
|
|
|
|
|
|
|
$m->xchg(1,2)->(,,($dims[2]-$min):)->ctricpy(1,$l); |
3872
|
|
|
|
|
|
|
} |
3873
|
|
|
|
|
|
|
} |
3874
|
|
|
|
|
|
|
return ($q->xchg(1,2)->sever, $l, $info); |
3875
|
|
|
|
|
|
|
|
3876
|
|
|
|
|
|
|
} |
3877
|
|
|
|
|
|
|
|
3878
|
|
|
|
|
|
|
=head2 mlq |
3879
|
|
|
|
|
|
|
|
3880
|
|
|
|
|
|
|
=for ref |
3881
|
|
|
|
|
|
|
|
3882
|
|
|
|
|
|
|
Computes LQ decomposition. |
3883
|
|
|
|
|
|
|
For complex number needs object of type PDL::Complex. |
3884
|
|
|
|
|
|
|
Uses L and L |
3885
|
|
|
|
|
|
|
or L and L |
3886
|
|
|
|
|
|
|
from Lapack and returns C in scalar context. Works on transposed array. |
3887
|
|
|
|
|
|
|
|
3888
|
|
|
|
|
|
|
=for usage |
3889
|
|
|
|
|
|
|
|
3890
|
|
|
|
|
|
|
( PDL(L), PDL(Q), PDL(info) ) = mlq(PDL, SCALAR) |
3891
|
|
|
|
|
|
|
SCALAR : ECONOMIC = 0 | FULL = 1, default = 0 |
3892
|
|
|
|
|
|
|
|
3893
|
|
|
|
|
|
|
=for example |
3894
|
|
|
|
|
|
|
|
3895
|
|
|
|
|
|
|
my $a = random(10,10); |
3896
|
|
|
|
|
|
|
my ( $l, $q ) = mlq($a); |
3897
|
|
|
|
|
|
|
# Can compute full decomposition if nrow < ncol |
3898
|
|
|
|
|
|
|
$a = random(5,7); |
3899
|
|
|
|
|
|
|
( $l, $q ) = $a->mlq(1); |
3900
|
|
|
|
|
|
|
|
3901
|
|
|
|
|
|
|
=cut |
3902
|
|
|
|
|
|
|
|
3903
|
|
|
|
|
|
|
sub mlq{ |
3904
|
|
|
|
|
|
|
my $m = shift; |
3905
|
|
|
|
|
|
|
$m->mlq(@_); |
3906
|
|
|
|
|
|
|
} |
3907
|
|
|
|
|
|
|
|
3908
|
|
|
|
|
|
|
sub PDL::mlq { |
3909
|
|
|
|
|
|
|
my($m, $full) = @_; |
3910
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
3911
|
|
|
|
|
|
|
my ($q, $l); |
3912
|
|
|
|
|
|
|
|
3913
|
|
|
|
|
|
|
barf("mlq: Require a matrix") unless @dims == 2; |
3914
|
|
|
|
|
|
|
$m = $m->xchg(0,1)->copy; |
3915
|
|
|
|
|
|
|
my $min = $dims[0] < $dims[1] ? $dims[0] : $dims[1]; |
3916
|
|
|
|
|
|
|
|
3917
|
|
|
|
|
|
|
my $tau = zeroes($m->type, $min); |
3918
|
|
|
|
|
|
|
$m->gelqf($tau, (my $info = pdl(long,0))); |
3919
|
|
|
|
|
|
|
if ($info){ |
3920
|
|
|
|
|
|
|
laerror("mlq: Error $info in gelqf\n"); |
3921
|
|
|
|
|
|
|
$q = $l = $m; |
3922
|
|
|
|
|
|
|
} |
3923
|
|
|
|
|
|
|
else{ |
3924
|
|
|
|
|
|
|
if ($dims[0] > $dims[1] && $full){ |
3925
|
|
|
|
|
|
|
$q = zeroes($m->type, $dims[0],$dims[0]); |
3926
|
|
|
|
|
|
|
$q(:($min -1),:) .= $m; |
3927
|
|
|
|
|
|
|
} |
3928
|
|
|
|
|
|
|
elsif ($dims[0] < $dims[1]){ |
3929
|
|
|
|
|
|
|
$q = $m(:($min-1),)->copy; |
3930
|
|
|
|
|
|
|
} |
3931
|
|
|
|
|
|
|
else{ |
3932
|
|
|
|
|
|
|
$q = $m->copy; |
3933
|
|
|
|
|
|
|
} |
3934
|
|
|
|
|
|
|
|
3935
|
|
|
|
|
|
|
$q->orglq($tau, $info); |
3936
|
|
|
|
|
|
|
return $q->xchg(0,1)->sever unless wantarray; |
3937
|
|
|
|
|
|
|
|
3938
|
|
|
|
|
|
|
if ($dims[0] > $dims[1] && !$full){ |
3939
|
|
|
|
|
|
|
$l = zeroes($m->type, $dims[1], $dims[1]); |
3940
|
|
|
|
|
|
|
$m->xchg(0,1)->(:($min-1))->tricpy(1,$l); |
3941
|
|
|
|
|
|
|
} |
3942
|
|
|
|
|
|
|
else{ |
3943
|
|
|
|
|
|
|
$l = zeroes($m->type, $dims[0], $dims[1]); |
3944
|
|
|
|
|
|
|
$m->xchg(0,1)->tricpy(1,$l); |
3945
|
|
|
|
|
|
|
} |
3946
|
|
|
|
|
|
|
} |
3947
|
|
|
|
|
|
|
return ($l, $q->xchg(0,1)->sever, $info); |
3948
|
|
|
|
|
|
|
|
3949
|
|
|
|
|
|
|
} |
3950
|
|
|
|
|
|
|
|
3951
|
|
|
|
|
|
|
sub PDL::Complex::mlq{ |
3952
|
|
|
|
|
|
|
my($m, $full) = @_; |
3953
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
3954
|
|
|
|
|
|
|
my ($q, $l); |
3955
|
|
|
|
|
|
|
|
3956
|
|
|
|
|
|
|
barf("mlq: Require a matrix") unless @dims == 3; |
3957
|
|
|
|
|
|
|
$m = $m->xchg(1,2)->copy; |
3958
|
|
|
|
|
|
|
my $min = $dims[1] < $dims[2] ? $dims[1] : $dims[2]; |
3959
|
|
|
|
|
|
|
|
3960
|
|
|
|
|
|
|
my $tau = zeroes($m->type, 2, $min); |
3961
|
|
|
|
|
|
|
$m->cgelqf($tau, (my $info = pdl(long,0))); |
3962
|
|
|
|
|
|
|
if ($info){ |
3963
|
|
|
|
|
|
|
laerror("mlq: Error $info in cgelqf\n"); |
3964
|
|
|
|
|
|
|
$q = $l = $m; |
3965
|
|
|
|
|
|
|
} |
3966
|
|
|
|
|
|
|
else{ |
3967
|
|
|
|
|
|
|
if ($dims[1] > $dims[2] && $full){ |
3968
|
|
|
|
|
|
|
$q = PDL::new_from_specification('PDL::Complex',$m->type, 2, $dims[1],$dims[1]); |
3969
|
|
|
|
|
|
|
$q .= 0; |
3970
|
|
|
|
|
|
|
$q(,:($min -1),:) .= $m; |
3971
|
|
|
|
|
|
|
} |
3972
|
|
|
|
|
|
|
elsif ($dims[1] < $dims[2]){ |
3973
|
|
|
|
|
|
|
$q = $m(,:($min-1),)->copy; |
3974
|
|
|
|
|
|
|
} |
3975
|
|
|
|
|
|
|
else{ |
3976
|
|
|
|
|
|
|
$q = $m->copy; |
3977
|
|
|
|
|
|
|
} |
3978
|
|
|
|
|
|
|
|
3979
|
|
|
|
|
|
|
$q->cunglq($tau, $info); |
3980
|
|
|
|
|
|
|
return $q->xchg(1,2)->sever unless wantarray; |
3981
|
|
|
|
|
|
|
|
3982
|
|
|
|
|
|
|
if ($dims[1] > $dims[2] && !$full){ |
3983
|
|
|
|
|
|
|
$l = PDL::new_from_specification('PDL::Complex',$m->type, 2, $dims[2], $dims[2]); |
3984
|
|
|
|
|
|
|
$l .= 0; |
3985
|
|
|
|
|
|
|
$m->xchg(1,2)->(,:($min-1))->ctricpy(1,$l); |
3986
|
|
|
|
|
|
|
} |
3987
|
|
|
|
|
|
|
else{ |
3988
|
|
|
|
|
|
|
$l = PDL::new_from_specification('PDL::Complex',$m->type, 2, $dims[1], $dims[2]); |
3989
|
|
|
|
|
|
|
$l .= 0; |
3990
|
|
|
|
|
|
|
$m->xchg(1,2)->ctricpy(1,$l); |
3991
|
|
|
|
|
|
|
} |
3992
|
|
|
|
|
|
|
} |
3993
|
|
|
|
|
|
|
return ($l, $q->xchg(1,2)->sever, $info); |
3994
|
|
|
|
|
|
|
|
3995
|
|
|
|
|
|
|
} |
3996
|
|
|
|
|
|
|
|
3997
|
|
|
|
|
|
|
=head2 msolve |
3998
|
|
|
|
|
|
|
|
3999
|
|
|
|
|
|
|
=for ref |
4000
|
|
|
|
|
|
|
|
4001
|
|
|
|
|
|
|
Solves linear system of equations using LU decomposition. |
4002
|
|
|
|
|
|
|
|
4003
|
|
|
|
|
|
|
A * X = B |
4004
|
|
|
|
|
|
|
|
4005
|
|
|
|
|
|
|
Returns X in scalar context else X, LU, pivot vector and info. |
4006
|
|
|
|
|
|
|
B is overwritten by X if its inplace flag is set. |
4007
|
|
|
|
|
|
|
Supports threading. |
4008
|
|
|
|
|
|
|
Uses L or L from Lapack. |
4009
|
|
|
|
|
|
|
Works on transposed arrays. |
4010
|
|
|
|
|
|
|
|
4011
|
|
|
|
|
|
|
=for usage |
4012
|
|
|
|
|
|
|
|
4013
|
|
|
|
|
|
|
(PDL(X), (PDL(LU), PDL(pivot), PDL(info))) = msolve(PDL(A), PDL(B) ) |
4014
|
|
|
|
|
|
|
|
4015
|
|
|
|
|
|
|
=for example |
4016
|
|
|
|
|
|
|
|
4017
|
|
|
|
|
|
|
my $a = random(5,5); |
4018
|
|
|
|
|
|
|
my $b = random(10,5); |
4019
|
|
|
|
|
|
|
my $X = msolve($a, $b); |
4020
|
|
|
|
|
|
|
|
4021
|
|
|
|
|
|
|
=cut |
4022
|
|
|
|
|
|
|
|
4023
|
|
|
|
|
|
|
|
4024
|
|
|
|
|
|
|
sub msolve{ |
4025
|
|
|
|
|
|
|
my $m = shift; |
4026
|
|
|
|
|
|
|
$m->msolve(@_); |
4027
|
|
|
|
|
|
|
} |
4028
|
|
|
|
|
|
|
|
4029
|
|
|
|
|
|
|
sub PDL::msolve { |
4030
|
|
|
|
|
|
|
my($a, $b) = @_; |
4031
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4032
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4033
|
|
|
|
|
|
|
my ($ipiv, $info, $c); |
4034
|
|
|
|
|
|
|
|
4035
|
|
|
|
|
|
|
barf("msolve: Require square coefficient array(s)") |
4036
|
|
|
|
|
|
|
unless( (@adims >= 2) && $adims[0] == $adims[1] ); |
4037
|
|
|
|
|
|
|
barf("msolve: Require right hand side array(s) B with number". |
4038
|
|
|
|
|
|
|
" of row equal to number of columns of A") |
4039
|
|
|
|
|
|
|
unless( (@bdims >= 2) && $bdims[1] == $adims[0]); |
4040
|
|
|
|
|
|
|
barf("msolve: Require arrays with equal number of dimensions") |
4041
|
|
|
|
|
|
|
if( @adims != @bdims); |
4042
|
|
|
|
|
|
|
|
4043
|
|
|
|
|
|
|
$a = $a->xchg(0,1)->copy; |
4044
|
|
|
|
|
|
|
$c = $b->is_inplace ? $b->xchg(0,1) : $b->xchg(0,1)->copy; |
4045
|
|
|
|
|
|
|
$ipiv = zeroes(long, @adims[1..$#adims]); |
4046
|
|
|
|
|
|
|
@adims = @adims[2..$#adims]; |
4047
|
|
|
|
|
|
|
$info = @adims ? zeroes(long,@adims) : pdl(long,0); |
4048
|
|
|
|
|
|
|
$a->gesv($c, $ipiv, $info); |
4049
|
|
|
|
|
|
|
|
4050
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
4051
|
|
|
|
|
|
|
my ($index,@list); |
4052
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
4053
|
|
|
|
|
|
|
@list = $index->list; |
4054
|
|
|
|
|
|
|
laerror("msolve: Can't solve system of linear equations (after getrf factorization): matrix (PDL(s) @list) is/are singular(s): \$info = $info"); |
4055
|
|
|
|
|
|
|
} |
4056
|
|
|
|
|
|
|
return wantarray ? $b->is_inplace(0) ? ($b, $a->xchg(0,1)->sever, $ipiv, $info) : ($c->xchg(0,1)->sever , $a->xchg(0,1)->sever, $ipiv, $info) : |
4057
|
|
|
|
|
|
|
$b->is_inplace(0) ? $b : $c->xchg(0,1)->sever; |
4058
|
|
|
|
|
|
|
|
4059
|
|
|
|
|
|
|
} |
4060
|
|
|
|
|
|
|
|
4061
|
|
|
|
|
|
|
sub PDL::Complex::msolve { |
4062
|
|
|
|
|
|
|
my($a, $b) = @_; |
4063
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4064
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4065
|
|
|
|
|
|
|
my ($ipiv, $info, $c); |
4066
|
|
|
|
|
|
|
|
4067
|
|
|
|
|
|
|
barf("msolve: Require square coefficient array(s)") |
4068
|
|
|
|
|
|
|
unless( (@adims >= 3) && $adims[1] == $adims[2] ); |
4069
|
|
|
|
|
|
|
barf("msolve: Require right hand side array(s) B with number". |
4070
|
|
|
|
|
|
|
" of row equal to order of A") |
4071
|
|
|
|
|
|
|
unless( (@bdims >= 3) && $bdims[2] == $adims[1]); |
4072
|
|
|
|
|
|
|
barf("msolve: Require arrays with equal number of dimensions") |
4073
|
|
|
|
|
|
|
if( @adims != @bdims); |
4074
|
|
|
|
|
|
|
|
4075
|
|
|
|
|
|
|
$a = $a->xchg(1,2)->copy; |
4076
|
|
|
|
|
|
|
$c = $b->is_inplace ? $b->xchg(1,2) : $b->xchg(1,2)->copy; |
4077
|
|
|
|
|
|
|
$ipiv = zeroes(long, @adims[2..$#adims]); |
4078
|
|
|
|
|
|
|
@adims = @adims[3..$#adims]; |
4079
|
|
|
|
|
|
|
$info = @adims ? zeroes(long,@adims) : pdl(long,0); |
4080
|
|
|
|
|
|
|
$a->cgesv($c, $ipiv, $info); |
4081
|
|
|
|
|
|
|
|
4082
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
4083
|
|
|
|
|
|
|
my ($index,@list); |
4084
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
4085
|
|
|
|
|
|
|
@list = $index->list; |
4086
|
|
|
|
|
|
|
laerror("msolve: Can't solve system of linear equations (after cgetrf factorization): matrix (PDL(s) @list) is/are singular(s): \$info = $info"); |
4087
|
|
|
|
|
|
|
} |
4088
|
|
|
|
|
|
|
return wantarray ? $b->is_inplace(0) ? ($b, $a->xchg(1,2)->sever, $ipiv, $info) : ($c->xchg(1,2)->sever , $a->xchg(1,2)->sever, $ipiv, $info): |
4089
|
|
|
|
|
|
|
$b->is_inplace(0) ? $b : $c->xchg(1,2)->sever; |
4090
|
|
|
|
|
|
|
|
4091
|
|
|
|
|
|
|
} |
4092
|
|
|
|
|
|
|
|
4093
|
|
|
|
|
|
|
=head2 msolvex |
4094
|
|
|
|
|
|
|
|
4095
|
|
|
|
|
|
|
=for ref |
4096
|
|
|
|
|
|
|
|
4097
|
|
|
|
|
|
|
Solves linear system of equations using LU decomposition. |
4098
|
|
|
|
|
|
|
|
4099
|
|
|
|
|
|
|
A * X = B |
4100
|
|
|
|
|
|
|
|
4101
|
|
|
|
|
|
|
Can optionnally equilibrate the matrix. |
4102
|
|
|
|
|
|
|
Uses L or L from Lapack. |
4103
|
|
|
|
|
|
|
Works on transposed arrays. |
4104
|
|
|
|
|
|
|
|
4105
|
|
|
|
|
|
|
=for usage |
4106
|
|
|
|
|
|
|
|
4107
|
|
|
|
|
|
|
(PDL, (HASH(result))) = msolvex(PDL(A), PDL(B), HASH(options)) |
4108
|
|
|
|
|
|
|
where options are: |
4109
|
|
|
|
|
|
|
transpose: solves A' * X = B |
4110
|
|
|
|
|
|
|
0: false |
4111
|
|
|
|
|
|
|
1: true |
4112
|
|
|
|
|
|
|
equilibrate: equilibrates A if necessary. |
4113
|
|
|
|
|
|
|
form equilibration is returned in HASH{'equilibration'}: |
4114
|
|
|
|
|
|
|
0: no equilibration |
4115
|
|
|
|
|
|
|
1: row equilibration |
4116
|
|
|
|
|
|
|
2: column equilibration |
4117
|
|
|
|
|
|
|
row scale factors are returned in HASH{'row'} |
4118
|
|
|
|
|
|
|
column scale factors are returned in HASH{'column'} |
4119
|
|
|
|
|
|
|
0: false |
4120
|
|
|
|
|
|
|
1: true |
4121
|
|
|
|
|
|
|
LU: returns lu decomposition in HASH{LU} |
4122
|
|
|
|
|
|
|
0: false |
4123
|
|
|
|
|
|
|
1: true |
4124
|
|
|
|
|
|
|
A: returns scaled A if equilibration was done in HASH{A} |
4125
|
|
|
|
|
|
|
0: false |
4126
|
|
|
|
|
|
|
1: true |
4127
|
|
|
|
|
|
|
B: returns scaled B if equilibration was done in HASH{B} |
4128
|
|
|
|
|
|
|
0: false |
4129
|
|
|
|
|
|
|
1: true |
4130
|
|
|
|
|
|
|
Returned values: |
4131
|
|
|
|
|
|
|
X (SCALAR CONTEXT), |
4132
|
|
|
|
|
|
|
HASH{'pivot'}: |
4133
|
|
|
|
|
|
|
Pivot indice from LU factorization |
4134
|
|
|
|
|
|
|
HASH{'rcondition'}: |
4135
|
|
|
|
|
|
|
Reciprocal condition of the matrix |
4136
|
|
|
|
|
|
|
HASH{'ferror'}: |
4137
|
|
|
|
|
|
|
Forward error bound |
4138
|
|
|
|
|
|
|
HASH{'berror'}: |
4139
|
|
|
|
|
|
|
Componentwise relative backward error |
4140
|
|
|
|
|
|
|
HASH{'rpvgrw'}: |
4141
|
|
|
|
|
|
|
Reciprocal pivot growth factor |
4142
|
|
|
|
|
|
|
HASH{'info'}: |
4143
|
|
|
|
|
|
|
Info: output from gesvx |
4144
|
|
|
|
|
|
|
|
4145
|
|
|
|
|
|
|
=for example |
4146
|
|
|
|
|
|
|
|
4147
|
|
|
|
|
|
|
my $a = random(10,10); |
4148
|
|
|
|
|
|
|
my $b = random(5,10); |
4149
|
|
|
|
|
|
|
my %options = ( |
4150
|
|
|
|
|
|
|
LU=>1, |
4151
|
|
|
|
|
|
|
equilibrate => 1, |
4152
|
|
|
|
|
|
|
); |
4153
|
|
|
|
|
|
|
my( $X, %result) = msolvex($a,$b,%options); |
4154
|
|
|
|
|
|
|
|
4155
|
|
|
|
|
|
|
=cut |
4156
|
|
|
|
|
|
|
|
4157
|
|
|
|
|
|
|
|
4158
|
|
|
|
|
|
|
*msolvex = \&PDL::msolvex; |
4159
|
|
|
|
|
|
|
|
4160
|
|
|
|
|
|
|
sub PDL::msolvex { |
4161
|
|
|
|
|
|
|
my($a, $b, %opt) = @_; |
4162
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4163
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4164
|
|
|
|
|
|
|
my ( $af, $x, $ipiv, $info, $equilibrate, $berr, $ferr, $rcond, $equed, %result, $r, $c ,$rpvgrw); |
4165
|
|
|
|
|
|
|
|
4166
|
|
|
|
|
|
|
barf("msolvex: Require a square coefficient matrix") |
4167
|
|
|
|
|
|
|
unless( ((@adims == 2) || (@adims == 3)) && $adims[-1] == $adims[-2] ); |
4168
|
|
|
|
|
|
|
barf("msolvex: Require a right hand side matrix B with number". |
4169
|
|
|
|
|
|
|
" of row equal to order of A") |
4170
|
|
|
|
|
|
|
unless( ((@bdims == 2) || (@bdims == 3))&& $bdims[-1] == $adims[-2]); |
4171
|
|
|
|
|
|
|
|
4172
|
|
|
|
|
|
|
|
4173
|
|
|
|
|
|
|
$equilibrate = $opt{'equilibrate'} ? pdl(long, 2): pdl(long,1); |
4174
|
|
|
|
|
|
|
$a = $a->t->copy; |
4175
|
|
|
|
|
|
|
$b = $b->t->copy; |
4176
|
|
|
|
|
|
|
$x = PDL::zeroes $b; |
4177
|
|
|
|
|
|
|
$af = PDL::zeroes $a; |
4178
|
|
|
|
|
|
|
$info = pdl(long, 0); |
4179
|
|
|
|
|
|
|
$rcond = null; |
4180
|
|
|
|
|
|
|
$rpvgrw = null; |
4181
|
|
|
|
|
|
|
$equed = pdl(long, 0); |
4182
|
|
|
|
|
|
|
|
4183
|
|
|
|
|
|
|
$c = zeroes($a->type, $adims[-2]); |
4184
|
|
|
|
|
|
|
$r = zeroes($a->type, $adims[-2]); |
4185
|
|
|
|
|
|
|
$ipiv = zeroes(long, $adims[-2]); |
4186
|
|
|
|
|
|
|
$ferr = zeroes($b->type, $bdims[-2]); |
4187
|
|
|
|
|
|
|
$berr = zeroes($b->type, $bdims[-2]); |
4188
|
|
|
|
|
|
|
|
4189
|
|
|
|
|
|
|
( @adims == 3 ) ? $a->cgesvx($opt{'transpose'}, $equilibrate, $b, $af, $ipiv, $equed, $r, $c, $x, $rcond, $ferr, $berr, $rpvgrw,$info) : |
4190
|
|
|
|
|
|
|
$a->gesvx($opt{'transpose'}, $equilibrate, $b, $af, $ipiv, $equed, $r, $c, $x, $rcond, $ferr, $berr, $rpvgrw,$info); |
4191
|
|
|
|
|
|
|
if( $info < $adims[-2] && $info > 0){ |
4192
|
|
|
|
|
|
|
$info--; |
4193
|
|
|
|
|
|
|
laerror("msolvex: Can't solve system of linear equations:\nfactor U($info,$info)". |
4194
|
|
|
|
|
|
|
" of coefficient matrix is exactly 0"); |
4195
|
|
|
|
|
|
|
} |
4196
|
|
|
|
|
|
|
elsif ($info != 0 and $_laerror){ |
4197
|
|
|
|
|
|
|
warn ("msolvex: The matrix is singular to working precision"); |
4198
|
|
|
|
|
|
|
} |
4199
|
|
|
|
|
|
|
|
4200
|
|
|
|
|
|
|
return $x->xchg(-1,-2)->sever unless wantarray; |
4201
|
|
|
|
|
|
|
|
4202
|
|
|
|
|
|
|
$result{rcondition} = $rcond; |
4203
|
|
|
|
|
|
|
$result{ferror} = $ferr; |
4204
|
|
|
|
|
|
|
$result{berror} = $berr; |
4205
|
|
|
|
|
|
|
if ($opt{equilibrate}){ |
4206
|
|
|
|
|
|
|
$result{equilibration} = $equed; |
4207
|
|
|
|
|
|
|
$result{row} = $r if $equed == 1 || $equed == 3; |
4208
|
|
|
|
|
|
|
$result{column} = $c if $equed == 2 || $equed == 3; |
4209
|
|
|
|
|
|
|
if ($equed){ |
4210
|
|
|
|
|
|
|
$result{A} = $a->xchg(-2,-1)->sever if $opt{A}; |
4211
|
|
|
|
|
|
|
$result{B} = $b->xchg(-2,-1)->sever if $opt{B}; |
4212
|
|
|
|
|
|
|
} |
4213
|
|
|
|
|
|
|
} |
4214
|
|
|
|
|
|
|
$result{pivot} = $ipiv; |
4215
|
|
|
|
|
|
|
$result{rpvgrw} = $rpvgrw; |
4216
|
|
|
|
|
|
|
$result{info} = $info; |
4217
|
|
|
|
|
|
|
$result{LU} = $af->xchg(-2,-1)->sever if $opt{LU}; |
4218
|
|
|
|
|
|
|
|
4219
|
|
|
|
|
|
|
return ($x->xchg(-2,-1)->sever, %result); |
4220
|
|
|
|
|
|
|
|
4221
|
|
|
|
|
|
|
} |
4222
|
|
|
|
|
|
|
|
4223
|
|
|
|
|
|
|
=head2 mtrisolve |
4224
|
|
|
|
|
|
|
|
4225
|
|
|
|
|
|
|
=for ref |
4226
|
|
|
|
|
|
|
|
4227
|
|
|
|
|
|
|
Solves linear system of equations with triangular matrix A. |
4228
|
|
|
|
|
|
|
|
4229
|
|
|
|
|
|
|
A * X = B or A' * X = B |
4230
|
|
|
|
|
|
|
|
4231
|
|
|
|
|
|
|
B is overwritten by X if its inplace flag is set. |
4232
|
|
|
|
|
|
|
Supports threading. |
4233
|
|
|
|
|
|
|
Uses L or L from Lapack. |
4234
|
|
|
|
|
|
|
Work on transposed array(s). |
4235
|
|
|
|
|
|
|
|
4236
|
|
|
|
|
|
|
=for usage |
4237
|
|
|
|
|
|
|
|
4238
|
|
|
|
|
|
|
(PDL(X), (PDL(info)) = mtrisolve(PDL(A), SCALAR(uplo), PDL(B), SCALAR(trans), SCALAR(diag)) |
4239
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1 |
4240
|
|
|
|
|
|
|
trans : NOTRANSPOSE = 0 | TRANSPOSE = 1, default = 0 |
4241
|
|
|
|
|
|
|
uplo : UNITARY DIAGONAL = 1, default = 0 |
4242
|
|
|
|
|
|
|
|
4243
|
|
|
|
|
|
|
=for example |
4244
|
|
|
|
|
|
|
|
4245
|
|
|
|
|
|
|
# Assume $a is upper triagonal |
4246
|
|
|
|
|
|
|
my $a = random(5,5); |
4247
|
|
|
|
|
|
|
my $b = random(5,10); |
4248
|
|
|
|
|
|
|
my $X = mtrisolve($a, 0, $b); |
4249
|
|
|
|
|
|
|
|
4250
|
|
|
|
|
|
|
=cut |
4251
|
|
|
|
|
|
|
|
4252
|
|
|
|
|
|
|
|
4253
|
|
|
|
|
|
|
sub mtrisolve{ |
4254
|
|
|
|
|
|
|
my $m = shift; |
4255
|
|
|
|
|
|
|
$m->mtrisolve(@_); |
4256
|
|
|
|
|
|
|
} |
4257
|
|
|
|
|
|
|
|
4258
|
|
|
|
|
|
|
sub PDL::mtrisolve{ |
4259
|
|
|
|
|
|
|
my($a, $uplo, $b, $trans, $diag) = @_; |
4260
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4261
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4262
|
|
|
|
|
|
|
my ($info, $c); |
4263
|
|
|
|
|
|
|
|
4264
|
|
|
|
|
|
|
barf("mtrisolve: Require square coefficient array(s)") |
4265
|
|
|
|
|
|
|
unless( (@adims >= 2) && $adims[0] == $adims[1] ); |
4266
|
|
|
|
|
|
|
barf("mtrisolve: Require 2D right hand side array(s) B with number". |
4267
|
|
|
|
|
|
|
" of row equal to order of A") |
4268
|
|
|
|
|
|
|
unless( (@bdims >= 2) && $bdims[1] == $adims[0]); |
4269
|
|
|
|
|
|
|
barf("mtrisolve: Require arrays with equal number of dimensions") |
4270
|
|
|
|
|
|
|
if( @adims != @bdims); |
4271
|
|
|
|
|
|
|
|
4272
|
|
|
|
|
|
|
$uplo = 1 - $uplo; |
4273
|
|
|
|
|
|
|
$trans = 1 - $trans; |
4274
|
|
|
|
|
|
|
$c = $b->is_inplace ? $b->xchg(0,1) : $b->xchg(0,1)->copy; |
4275
|
|
|
|
|
|
|
@adims = @adims[2..$#adims]; |
4276
|
|
|
|
|
|
|
$info = @adims ? zeroes(long,@adims) : pdl(long,0); |
4277
|
|
|
|
|
|
|
$a->trtrs($uplo, $trans, $diag, $c, $info); |
4278
|
|
|
|
|
|
|
|
4279
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
4280
|
|
|
|
|
|
|
my ($index,@list); |
4281
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
4282
|
|
|
|
|
|
|
@list = $index->list; |
4283
|
|
|
|
|
|
|
laerror("mtrisolve: Can't solve system of linear equations: matrix (PDL(s) @list) is/are singular(s): \$info = $info"); |
4284
|
|
|
|
|
|
|
} |
4285
|
|
|
|
|
|
|
return wantarray ? $b->is_inplace(0) ? ($b, $info) : ($c->xchg(0,1)->sever, $info) : |
4286
|
|
|
|
|
|
|
$b->is_inplace(0) ? $b : $c->xchg(0,1)->sever; |
4287
|
|
|
|
|
|
|
} |
4288
|
|
|
|
|
|
|
|
4289
|
|
|
|
|
|
|
sub PDL::Complex::mtrisolve{ |
4290
|
|
|
|
|
|
|
my($a, $uplo, $b, $trans, $diag) = @_; |
4291
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4292
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4293
|
|
|
|
|
|
|
my ($info, $c); |
4294
|
|
|
|
|
|
|
|
4295
|
|
|
|
|
|
|
barf("mtrisolve: Require square coefficient array(s)") |
4296
|
|
|
|
|
|
|
unless( (@adims >= 3) && $adims[1] == $adims[2] ); |
4297
|
|
|
|
|
|
|
barf("mtrisolve: Require 2D right hand side array(s) B with number". |
4298
|
|
|
|
|
|
|
" of row equal to order of A") |
4299
|
|
|
|
|
|
|
unless( (@bdims >= 3) && $bdims[2] == $adims[1]); |
4300
|
|
|
|
|
|
|
barf("mtrisolve: Require arrays with equal number of dimensions") |
4301
|
|
|
|
|
|
|
if( @adims != @bdims); |
4302
|
|
|
|
|
|
|
|
4303
|
|
|
|
|
|
|
$uplo = 1 - $uplo; |
4304
|
|
|
|
|
|
|
$trans = 1 - $trans; |
4305
|
|
|
|
|
|
|
$c = $b->is_inplace ? $b->xchg(1,2) : $b->xchg(1,2)->copy; |
4306
|
|
|
|
|
|
|
@adims = @adims[3..$#adims]; |
4307
|
|
|
|
|
|
|
$info = @adims ? zeroes(long,@adims) : pdl(long,0); |
4308
|
|
|
|
|
|
|
$a->ctrtrs($uplo, $trans, $diag, $c, $info); |
4309
|
|
|
|
|
|
|
|
4310
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
4311
|
|
|
|
|
|
|
my ($index,@list); |
4312
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
4313
|
|
|
|
|
|
|
@list = $index->list; |
4314
|
|
|
|
|
|
|
laerror("mtrisolve: Can't solve system of linear equations: matrix (PDL(s) @list) is/are singular(s): \$info = $info"); |
4315
|
|
|
|
|
|
|
} |
4316
|
|
|
|
|
|
|
return wantarray ? $b->is_inplace(0) ? ($b, $info) : ($c->xchg(1,2)->sever, $info) : |
4317
|
|
|
|
|
|
|
$b->is_inplace(0) ? $b : $c->xchg(1,2)->sever; |
4318
|
|
|
|
|
|
|
} |
4319
|
|
|
|
|
|
|
|
4320
|
|
|
|
|
|
|
=head2 msymsolve |
4321
|
|
|
|
|
|
|
|
4322
|
|
|
|
|
|
|
=for ref |
4323
|
|
|
|
|
|
|
|
4324
|
|
|
|
|
|
|
Solves linear system of equations using diagonal pivoting method with symmetric matrix A. |
4325
|
|
|
|
|
|
|
|
4326
|
|
|
|
|
|
|
A * X = B |
4327
|
|
|
|
|
|
|
|
4328
|
|
|
|
|
|
|
Returns X in scalar context else X, block diagonal matrix D (and the |
4329
|
|
|
|
|
|
|
multipliers), pivot vector an info. B is overwritten by X if its inplace flag is set. |
4330
|
|
|
|
|
|
|
Supports threading. |
4331
|
|
|
|
|
|
|
Uses L or L from Lapack. |
4332
|
|
|
|
|
|
|
Works on transposed array(s). |
4333
|
|
|
|
|
|
|
|
4334
|
|
|
|
|
|
|
=for usage |
4335
|
|
|
|
|
|
|
|
4336
|
|
|
|
|
|
|
(PDL(X), ( PDL(D), PDL(pivot), PDL(info) ) ) = msymsolve(PDL(A), SCALAR(uplo), PDL(B) ) |
4337
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1, default = 0 |
4338
|
|
|
|
|
|
|
|
4339
|
|
|
|
|
|
|
=for example |
4340
|
|
|
|
|
|
|
|
4341
|
|
|
|
|
|
|
# Assume $a is symmetric |
4342
|
|
|
|
|
|
|
my $a = random(5,5); |
4343
|
|
|
|
|
|
|
my $b = random(5,10); |
4344
|
|
|
|
|
|
|
my $X = msymsolve($a, 0, $b); |
4345
|
|
|
|
|
|
|
|
4346
|
|
|
|
|
|
|
=cut |
4347
|
|
|
|
|
|
|
|
4348
|
|
|
|
|
|
|
sub msymsolve{ |
4349
|
|
|
|
|
|
|
my $m = shift; |
4350
|
|
|
|
|
|
|
$m->msymsolve(@_); |
4351
|
|
|
|
|
|
|
} |
4352
|
|
|
|
|
|
|
|
4353
|
|
|
|
|
|
|
sub PDL::msymsolve { |
4354
|
|
|
|
|
|
|
my($a, $uplo, $b) = @_; |
4355
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4356
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4357
|
|
|
|
|
|
|
my ($ipiv, $info, $c); |
4358
|
|
|
|
|
|
|
|
4359
|
|
|
|
|
|
|
barf("msymsolve: Require square coefficient array(s)") |
4360
|
|
|
|
|
|
|
unless( (@adims >= 2) && $adims[0] == $adims[1] ); |
4361
|
|
|
|
|
|
|
barf("msymsolve: Require 2D right hand side array(s) B with number". |
4362
|
|
|
|
|
|
|
" of row equal to order of A") |
4363
|
|
|
|
|
|
|
unless( (@bdims >= 2)&& $bdims[1] == $adims[0]); |
4364
|
|
|
|
|
|
|
barf("msymsolve: Require array(s) with equal number of dimensions") |
4365
|
|
|
|
|
|
|
if( @adims != @bdims); |
4366
|
|
|
|
|
|
|
|
4367
|
|
|
|
|
|
|
$uplo = 1 - $uplo; |
4368
|
|
|
|
|
|
|
$a = $a->copy; |
4369
|
|
|
|
|
|
|
$c = $b->is_inplace ? $b->xchg(0,1) : $b->xchg(0,1)->copy; |
4370
|
|
|
|
|
|
|
$ipiv = zeroes(long, @adims[1..$#adims]); |
4371
|
|
|
|
|
|
|
@adims = @adims[2..$#adims]; |
4372
|
|
|
|
|
|
|
$info = @adims ? zeroes(long,@adims) : pdl(long,0); |
4373
|
|
|
|
|
|
|
|
4374
|
|
|
|
|
|
|
$a->sysv($uplo, $c, $ipiv, $info); |
4375
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
4376
|
|
|
|
|
|
|
my ($index,@list); |
4377
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
4378
|
|
|
|
|
|
|
@list = $index->list; |
4379
|
|
|
|
|
|
|
laerror("msymsolve: Can't solve system of linear equations (after sytrf factorization): matrix (PDL(s) @list) is/are singular(s): \$info = $info"); |
4380
|
|
|
|
|
|
|
} |
4381
|
|
|
|
|
|
|
|
4382
|
|
|
|
|
|
|
|
4383
|
|
|
|
|
|
|
wantarray ? ( ( $b->is_inplace(0) ? $b : $c->xchg(0,1)->sever ), $a, $ipiv, $info): |
4384
|
|
|
|
|
|
|
$b->is_inplace(0) ? $b : $c->xchg(0,1)->sever; |
4385
|
|
|
|
|
|
|
|
4386
|
|
|
|
|
|
|
} |
4387
|
|
|
|
|
|
|
|
4388
|
|
|
|
|
|
|
sub PDL::Complex::msymsolve { |
4389
|
|
|
|
|
|
|
my($a, $uplo, $b) = @_; |
4390
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4391
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4392
|
|
|
|
|
|
|
my ($ipiv, $info, $c); |
4393
|
|
|
|
|
|
|
|
4394
|
|
|
|
|
|
|
barf("msymsolve: Require square coefficient array(s)") |
4395
|
|
|
|
|
|
|
unless( (@adims >= 3) && $adims[1] == $adims[2] ); |
4396
|
|
|
|
|
|
|
barf("msymsolve: Require 2D right hand side array(s) B with number". |
4397
|
|
|
|
|
|
|
" of row equal to order of A") |
4398
|
|
|
|
|
|
|
unless( (@bdims >= 3)&& $bdims[2] == $adims[1]); |
4399
|
|
|
|
|
|
|
barf("msymsolve: Require arrays with equal number of dimensions") |
4400
|
|
|
|
|
|
|
if( @adims != @bdims); |
4401
|
|
|
|
|
|
|
|
4402
|
|
|
|
|
|
|
$uplo = 1 - $uplo; |
4403
|
|
|
|
|
|
|
$a = $a->copy; |
4404
|
|
|
|
|
|
|
$c = $b->is_inplace ? $b->xchg(1,2) : $b->xchg(1,2)->copy; |
4405
|
|
|
|
|
|
|
$ipiv = zeroes(long, @adims[2..$#adims]); |
4406
|
|
|
|
|
|
|
@adims = @adims[3..$#adims]; |
4407
|
|
|
|
|
|
|
$info = @adims ? zeroes(long,@adims) : pdl(long,0); |
4408
|
|
|
|
|
|
|
|
4409
|
|
|
|
|
|
|
$a->csysv($uplo, $c, $ipiv, $info); |
4410
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
4411
|
|
|
|
|
|
|
my ($index,@list); |
4412
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
4413
|
|
|
|
|
|
|
@list = $index->list; |
4414
|
|
|
|
|
|
|
laerror("msymsolve: Can't solve system of linear equations (after csytrf factorization): matrix (PDL(s) @list) is/are singular(s): \$info = $info"); |
4415
|
|
|
|
|
|
|
} |
4416
|
|
|
|
|
|
|
|
4417
|
|
|
|
|
|
|
|
4418
|
|
|
|
|
|
|
wantarray ? ( ( $b->is_inplace(0) ? $b : $c->xchg(1,2)->sever ), $a, $ipiv, $info): |
4419
|
|
|
|
|
|
|
$b->is_inplace(0) ? $b : $c->xchg(1,2)->sever; |
4420
|
|
|
|
|
|
|
|
4421
|
|
|
|
|
|
|
} |
4422
|
|
|
|
|
|
|
|
4423
|
|
|
|
|
|
|
=head2 msymsolvex |
4424
|
|
|
|
|
|
|
|
4425
|
|
|
|
|
|
|
=for ref |
4426
|
|
|
|
|
|
|
|
4427
|
|
|
|
|
|
|
Solves linear system of equations using diagonal pivoting method with symmetric matrix A. |
4428
|
|
|
|
|
|
|
|
4429
|
|
|
|
|
|
|
A * X = B |
4430
|
|
|
|
|
|
|
|
4431
|
|
|
|
|
|
|
Uses L or L |
4432
|
|
|
|
|
|
|
from Lapack. Works on transposed array. |
4433
|
|
|
|
|
|
|
|
4434
|
|
|
|
|
|
|
=for usage |
4435
|
|
|
|
|
|
|
|
4436
|
|
|
|
|
|
|
(PDL, (HASH(result))) = msymsolvex(PDL(A), SCALAR (uplo), PDL(B), SCALAR(d)) |
4437
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1, default = 0 |
4438
|
|
|
|
|
|
|
d : whether return diagonal matrix d and pivot vector |
4439
|
|
|
|
|
|
|
FALSE = 0 | TRUE = 1, default = 0 |
4440
|
|
|
|
|
|
|
Returned values: |
4441
|
|
|
|
|
|
|
X (SCALAR CONTEXT), |
4442
|
|
|
|
|
|
|
HASH{'D'}: |
4443
|
|
|
|
|
|
|
Block diagonal matrix D (and the multipliers) (if requested) |
4444
|
|
|
|
|
|
|
HASH{'pivot'}: |
4445
|
|
|
|
|
|
|
Pivot indice from LU factorization (if requested) |
4446
|
|
|
|
|
|
|
HASH{'rcondition'}: |
4447
|
|
|
|
|
|
|
Reciprocal condition of the matrix |
4448
|
|
|
|
|
|
|
HASH{'ferror'}: |
4449
|
|
|
|
|
|
|
Forward error bound |
4450
|
|
|
|
|
|
|
HASH{'berror'}: |
4451
|
|
|
|
|
|
|
Componentwise relative backward error |
4452
|
|
|
|
|
|
|
HASH{'info'}: |
4453
|
|
|
|
|
|
|
Info: output from sysvx |
4454
|
|
|
|
|
|
|
|
4455
|
|
|
|
|
|
|
=for example |
4456
|
|
|
|
|
|
|
|
4457
|
|
|
|
|
|
|
# Assume $a is symmetric |
4458
|
|
|
|
|
|
|
my $a = random(10,10); |
4459
|
|
|
|
|
|
|
my $b = random(5,10); |
4460
|
|
|
|
|
|
|
my ($X, %result) = msolvex($a, 0, $b); |
4461
|
|
|
|
|
|
|
|
4462
|
|
|
|
|
|
|
|
4463
|
|
|
|
|
|
|
=cut |
4464
|
|
|
|
|
|
|
|
4465
|
|
|
|
|
|
|
|
4466
|
|
|
|
|
|
|
*msymsolvex = \&PDL::msymsolvex; |
4467
|
|
|
|
|
|
|
|
4468
|
|
|
|
|
|
|
sub PDL::msymsolvex { |
4469
|
|
|
|
|
|
|
my($a, $uplo, $b, $d) = @_; |
4470
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4471
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4472
|
|
|
|
|
|
|
my ( $af, $x, $ipiv, $info, $berr, $ferr, $rcond, %result); |
4473
|
|
|
|
|
|
|
|
4474
|
|
|
|
|
|
|
barf("msymsolvex: Require a square coefficient matrix") |
4475
|
|
|
|
|
|
|
unless( ((@adims == 2) || (@adims == 3)) && $adims[-1] == $adims[-2] ); |
4476
|
|
|
|
|
|
|
barf("msymsolvex: Require a right hand side matrix B with number". |
4477
|
|
|
|
|
|
|
" of row equal to order of A") |
4478
|
|
|
|
|
|
|
unless( ((@bdims == 2) || (@bdims == 3))&& $bdims[-1] == $adims[-2]); |
4479
|
|
|
|
|
|
|
|
4480
|
|
|
|
|
|
|
|
4481
|
|
|
|
|
|
|
$uplo = 1 - $uplo; |
4482
|
|
|
|
|
|
|
$b = $b->t; |
4483
|
|
|
|
|
|
|
$x = PDL::zeroes $b; |
4484
|
|
|
|
|
|
|
$af = PDL::zeroes $a; |
4485
|
|
|
|
|
|
|
$info = pdl(long, 0); |
4486
|
|
|
|
|
|
|
$rcond = null; |
4487
|
|
|
|
|
|
|
|
4488
|
|
|
|
|
|
|
$ipiv = zeroes(long, $adims[-2]); |
4489
|
|
|
|
|
|
|
$ferr = zeroes($b->type, $bdims[-2]); |
4490
|
|
|
|
|
|
|
$berr = zeroes($b->type, $bdims[-2]); |
4491
|
|
|
|
|
|
|
|
4492
|
|
|
|
|
|
|
(@adims == 3) ? $a->csysvx($uplo, (pdl(long, 0)), $b, $af, $ipiv, $x, $rcond, $ferr, $berr, $info) : |
4493
|
|
|
|
|
|
|
$a->sysvx($uplo, (pdl(long, 0)), $b, $af, $ipiv, $x, $rcond, $ferr, $berr, $info); |
4494
|
|
|
|
|
|
|
if( $info < $adims[-2] && $info > 0){ |
4495
|
|
|
|
|
|
|
$info--; |
4496
|
|
|
|
|
|
|
laerror("msymsolvex: Can't solve system of linear equations:\nfactor D($info,$info)". |
4497
|
|
|
|
|
|
|
" of coefficient matrix is exactly 0"); |
4498
|
|
|
|
|
|
|
} |
4499
|
|
|
|
|
|
|
elsif ($info != 0 and $_laerror){ |
4500
|
|
|
|
|
|
|
warn("msymsolvex: The matrix is singular to working precision"); |
4501
|
|
|
|
|
|
|
} |
4502
|
|
|
|
|
|
|
$result{rcondition} = $rcond; |
4503
|
|
|
|
|
|
|
$result{ferror} = $ferr; |
4504
|
|
|
|
|
|
|
$result{berror} = $berr; |
4505
|
|
|
|
|
|
|
$result{info} = $info; |
4506
|
|
|
|
|
|
|
if ($d){ |
4507
|
|
|
|
|
|
|
$result{D} = $af; |
4508
|
|
|
|
|
|
|
$result{pivot} = $ipiv; |
4509
|
|
|
|
|
|
|
} |
4510
|
|
|
|
|
|
|
|
4511
|
|
|
|
|
|
|
wantarray ? ($x->xchg(-2,-1)->sever, %result): $x->xchg(-2,-1)->sever; |
4512
|
|
|
|
|
|
|
|
4513
|
|
|
|
|
|
|
} |
4514
|
|
|
|
|
|
|
|
4515
|
|
|
|
|
|
|
=head2 mpossolve |
4516
|
|
|
|
|
|
|
|
4517
|
|
|
|
|
|
|
=for ref |
4518
|
|
|
|
|
|
|
|
4519
|
|
|
|
|
|
|
Solves linear system of equations using Cholesky decomposition with |
4520
|
|
|
|
|
|
|
symmetric positive definite matrix A. |
4521
|
|
|
|
|
|
|
|
4522
|
|
|
|
|
|
|
A * X = B |
4523
|
|
|
|
|
|
|
|
4524
|
|
|
|
|
|
|
Returns X in scalar context else X, U or L and info. |
4525
|
|
|
|
|
|
|
B is overwritten by X if its inplace flag is set. |
4526
|
|
|
|
|
|
|
Supports threading. |
4527
|
|
|
|
|
|
|
Uses L or L from Lapack. |
4528
|
|
|
|
|
|
|
Works on transposed array(s). |
4529
|
|
|
|
|
|
|
|
4530
|
|
|
|
|
|
|
=for usage |
4531
|
|
|
|
|
|
|
|
4532
|
|
|
|
|
|
|
(PDL, (PDL, PDL, PDL)) = mpossolve(PDL(A), SCALAR(uplo), PDL(B) ) |
4533
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1, default = 0 |
4534
|
|
|
|
|
|
|
|
4535
|
|
|
|
|
|
|
=for example |
4536
|
|
|
|
|
|
|
|
4537
|
|
|
|
|
|
|
# asume $a is symmetric positive definite |
4538
|
|
|
|
|
|
|
my $a = random(5,5); |
4539
|
|
|
|
|
|
|
my $b = random(5,10); |
4540
|
|
|
|
|
|
|
my $X = mpossolve($a, 0, $b); |
4541
|
|
|
|
|
|
|
|
4542
|
|
|
|
|
|
|
=cut |
4543
|
|
|
|
|
|
|
|
4544
|
|
|
|
|
|
|
|
4545
|
|
|
|
|
|
|
sub mpossolve{ |
4546
|
|
|
|
|
|
|
my $m = shift; |
4547
|
|
|
|
|
|
|
$m->mpossolve(@_); |
4548
|
|
|
|
|
|
|
} |
4549
|
|
|
|
|
|
|
|
4550
|
|
|
|
|
|
|
sub PDL::mpossolve { |
4551
|
|
|
|
|
|
|
my($a, $uplo, $b) = @_; |
4552
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4553
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4554
|
|
|
|
|
|
|
my ($info, $c); |
4555
|
|
|
|
|
|
|
|
4556
|
|
|
|
|
|
|
barf("mpossolve: Require square coefficient array(s)") |
4557
|
|
|
|
|
|
|
unless( (@adims >= 2) && $adims[0] == $adims[1] ); |
4558
|
|
|
|
|
|
|
barf("mpossolve: Require right hand side array(s) B with number". |
4559
|
|
|
|
|
|
|
" of row equal to order of A") |
4560
|
|
|
|
|
|
|
unless( (@bdims >= 2)&& $bdims[1] == $adims[0]); |
4561
|
|
|
|
|
|
|
barf("mpossolve: Require arrays with equal number of dimensions") |
4562
|
|
|
|
|
|
|
if( @adims != @bdims); |
4563
|
|
|
|
|
|
|
|
4564
|
|
|
|
|
|
|
$uplo = 1 - $uplo; |
4565
|
|
|
|
|
|
|
$a = $a->copy; |
4566
|
|
|
|
|
|
|
$c = $b->is_inplace ? $b->xchg(0,1) : $b->xchg(0,1)->copy; |
4567
|
|
|
|
|
|
|
@adims = @adims[2..$#adims]; |
4568
|
|
|
|
|
|
|
$info = @adims ? zeroes(long,@adims) : pdl(long,0); |
4569
|
|
|
|
|
|
|
$a->posv($uplo, $c, $info); |
4570
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
4571
|
|
|
|
|
|
|
my ($index,@list); |
4572
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
4573
|
|
|
|
|
|
|
@list = $index->list; |
4574
|
|
|
|
|
|
|
laerror("mpossolve: Can't solve system of linear equations: matrix (PDL(s) @list) is/are not positive definite(s): \$info = $info"); |
4575
|
|
|
|
|
|
|
} |
4576
|
|
|
|
|
|
|
wantarray ? $b->is_inplace(0) ? ($b, $a,$info) : ($c->xchg(0,1)->sever , $a,$info) : $b->is_inplace(0) ? $b : $c->xchg(0,1)->sever; |
4577
|
|
|
|
|
|
|
} |
4578
|
|
|
|
|
|
|
|
4579
|
|
|
|
|
|
|
sub PDL::Complex::mpossolve { |
4580
|
|
|
|
|
|
|
my($a, $uplo, $b) = @_; |
4581
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4582
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4583
|
|
|
|
|
|
|
my ($info, $c); |
4584
|
|
|
|
|
|
|
|
4585
|
|
|
|
|
|
|
barf("mpossolve: Require square coefficient array(s)") |
4586
|
|
|
|
|
|
|
unless( (@adims >= 3) && $adims[1] == $adims[2] ); |
4587
|
|
|
|
|
|
|
barf("mpossolve: Require right hand side array(s) B with number". |
4588
|
|
|
|
|
|
|
" of row equal to order of A") |
4589
|
|
|
|
|
|
|
unless( (@bdims >= 3)&& $bdims[2] == $adims[1]); |
4590
|
|
|
|
|
|
|
barf("mpossolve: Require arrays with equal number of dimensions") |
4591
|
|
|
|
|
|
|
if( @adims != @bdims); |
4592
|
|
|
|
|
|
|
|
4593
|
|
|
|
|
|
|
$uplo = 1 - $uplo; |
4594
|
|
|
|
|
|
|
$a = $a->copy; |
4595
|
|
|
|
|
|
|
$c = $b->is_inplace ? $b->xchg(1,2) : $b->xchg(1,2)->copy; |
4596
|
|
|
|
|
|
|
@adims = @adims[3..$#adims]; |
4597
|
|
|
|
|
|
|
$info = @adims ? zeroes(long,@adims) : pdl(long,0); |
4598
|
|
|
|
|
|
|
$a->cposv($uplo, $c, $info); |
4599
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
4600
|
|
|
|
|
|
|
my ($index,@list); |
4601
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
4602
|
|
|
|
|
|
|
@list = $index->list; |
4603
|
|
|
|
|
|
|
laerror("mpossolve: Can't solve system of linear equations: matrix (PDL(s) @list) is/are not positive definite(s): \$info = $info"); |
4604
|
|
|
|
|
|
|
} |
4605
|
|
|
|
|
|
|
wantarray ? $b->is_inplace(0) ? ($b, $a,$info) : ($c->xchg(1,2)->sever , $a,$info) : $b->is_inplace(0) ? $b : $c->xchg(1,2)->sever; |
4606
|
|
|
|
|
|
|
} |
4607
|
|
|
|
|
|
|
|
4608
|
|
|
|
|
|
|
=head2 mpossolvex |
4609
|
|
|
|
|
|
|
|
4610
|
|
|
|
|
|
|
=for ref |
4611
|
|
|
|
|
|
|
|
4612
|
|
|
|
|
|
|
Solves linear system of equations using Cholesky decomposition with |
4613
|
|
|
|
|
|
|
symmetric positive definite matrix A |
4614
|
|
|
|
|
|
|
|
4615
|
|
|
|
|
|
|
A * X = B |
4616
|
|
|
|
|
|
|
|
4617
|
|
|
|
|
|
|
Can optionnally equilibrate the matrix. |
4618
|
|
|
|
|
|
|
Uses L or |
4619
|
|
|
|
|
|
|
L from Lapack. |
4620
|
|
|
|
|
|
|
Works on transposed array(s). |
4621
|
|
|
|
|
|
|
|
4622
|
|
|
|
|
|
|
=for usage |
4623
|
|
|
|
|
|
|
|
4624
|
|
|
|
|
|
|
(PDL, (HASH(result))) = mpossolvex(PDL(A), SCARA(uplo), PDL(B), HASH(options)) |
4625
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1, default = 0 |
4626
|
|
|
|
|
|
|
where options are: |
4627
|
|
|
|
|
|
|
equilibrate: equilibrates A if necessary. |
4628
|
|
|
|
|
|
|
form equilibration is returned in HASH{'equilibration'}: |
4629
|
|
|
|
|
|
|
0: no equilibration |
4630
|
|
|
|
|
|
|
1: equilibration |
4631
|
|
|
|
|
|
|
scale factors are returned in HASH{'scale'} |
4632
|
|
|
|
|
|
|
0: false |
4633
|
|
|
|
|
|
|
1: true |
4634
|
|
|
|
|
|
|
U|L: returns Cholesky factorization in HASH{U} or HASH{L} |
4635
|
|
|
|
|
|
|
0: false |
4636
|
|
|
|
|
|
|
1: true |
4637
|
|
|
|
|
|
|
A: returns scaled A if equilibration was done in HASH{A} |
4638
|
|
|
|
|
|
|
0: false |
4639
|
|
|
|
|
|
|
1: true |
4640
|
|
|
|
|
|
|
B: returns scaled B if equilibration was done in HASH{B} |
4641
|
|
|
|
|
|
|
0: false |
4642
|
|
|
|
|
|
|
1: true |
4643
|
|
|
|
|
|
|
Returned values: |
4644
|
|
|
|
|
|
|
X (SCALAR CONTEXT), |
4645
|
|
|
|
|
|
|
HASH{'rcondition'}: |
4646
|
|
|
|
|
|
|
Reciprocal condition of the matrix |
4647
|
|
|
|
|
|
|
HASH{'ferror'}: |
4648
|
|
|
|
|
|
|
Forward error bound |
4649
|
|
|
|
|
|
|
HASH{'berror'}: |
4650
|
|
|
|
|
|
|
Componentwise relative backward error |
4651
|
|
|
|
|
|
|
HASH{'info'}: |
4652
|
|
|
|
|
|
|
Info: output from gesvx |
4653
|
|
|
|
|
|
|
|
4654
|
|
|
|
|
|
|
=for example |
4655
|
|
|
|
|
|
|
|
4656
|
|
|
|
|
|
|
# Assume $a is symmetric positive definite |
4657
|
|
|
|
|
|
|
my $a = random(10,10); |
4658
|
|
|
|
|
|
|
my $b = random(5,10); |
4659
|
|
|
|
|
|
|
my %options = (U=>1, |
4660
|
|
|
|
|
|
|
equilibrate => 1, |
4661
|
|
|
|
|
|
|
); |
4662
|
|
|
|
|
|
|
my ($X, %result) = msolvex($a, 0, $b,%opt); |
4663
|
|
|
|
|
|
|
|
4664
|
|
|
|
|
|
|
=cut |
4665
|
|
|
|
|
|
|
|
4666
|
|
|
|
|
|
|
|
4667
|
|
|
|
|
|
|
*mpossolvex = \&PDL::mpossolvex; |
4668
|
|
|
|
|
|
|
|
4669
|
|
|
|
|
|
|
sub PDL::mpossolvex { |
4670
|
|
|
|
|
|
|
my($a, $uplo, $b, %opt) = @_; |
4671
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4672
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4673
|
|
|
|
|
|
|
my ( $af, $x, $info, $equilibrate, $berr, $ferr, $rcond, $equed, %result, $s); |
4674
|
|
|
|
|
|
|
|
4675
|
|
|
|
|
|
|
barf("mpossolvex: Require a square coefficient matrix") |
4676
|
|
|
|
|
|
|
unless( ((@adims == 2) || (@adims == 3)) && $adims[-1] == $adims[-2] ); |
4677
|
|
|
|
|
|
|
barf("mpossolvex: Require a 2D right hand side matrix B with number". |
4678
|
|
|
|
|
|
|
" of row equal to order of A") |
4679
|
|
|
|
|
|
|
unless( ((@bdims == 2) || (@bdims == 3))&& $bdims[-1] == $adims[-2]); |
4680
|
|
|
|
|
|
|
|
4681
|
|
|
|
|
|
|
|
4682
|
|
|
|
|
|
|
$uplo = $uplo ? pdl(long, 0): pdl(long, 1); |
4683
|
|
|
|
|
|
|
$equilibrate = $opt{'equilibrate'} ? pdl(long, 2): pdl(long,1); |
4684
|
|
|
|
|
|
|
$a = $a->copy; |
4685
|
|
|
|
|
|
|
$b = $b->t->copy; |
4686
|
|
|
|
|
|
|
$x = PDL::zeroes $b; |
4687
|
|
|
|
|
|
|
$af = PDL::zeroes $a; |
4688
|
|
|
|
|
|
|
$info = pdl(long, 0); |
4689
|
|
|
|
|
|
|
$rcond = null; |
4690
|
|
|
|
|
|
|
$equed = pdl(long, 0); |
4691
|
|
|
|
|
|
|
|
4692
|
|
|
|
|
|
|
$s = zeroes($a->type, $adims[-2]); |
4693
|
|
|
|
|
|
|
$ferr = zeroes($b->type, $bdims[-2]); |
4694
|
|
|
|
|
|
|
$berr = zeroes($b->type, $bdims[-2]); |
4695
|
|
|
|
|
|
|
|
4696
|
|
|
|
|
|
|
(@adims == 3) ? $a->cposvx($uplo, $equilibrate, $b, $af, $equed, $s, $x, $rcond, $ferr, $berr, $info) : |
4697
|
|
|
|
|
|
|
$a->posvx($uplo, $equilibrate, $b, $af, $equed, $s, $x, $rcond, $ferr, $berr, $info); |
4698
|
|
|
|
|
|
|
if( $info < $adims[-2] && $info > 0){ |
4699
|
|
|
|
|
|
|
$info--; |
4700
|
|
|
|
|
|
|
barf("mpossolvex: Can't solve system of linear equations:\n". |
4701
|
|
|
|
|
|
|
"the leading minor of order $info of A is". |
4702
|
|
|
|
|
|
|
" not positive definite"); |
4703
|
|
|
|
|
|
|
return; |
4704
|
|
|
|
|
|
|
} |
4705
|
|
|
|
|
|
|
elsif ( $info and $_laerror){ |
4706
|
|
|
|
|
|
|
warn("mpossolvex: The matrix is singular to working precision"); |
4707
|
|
|
|
|
|
|
} |
4708
|
|
|
|
|
|
|
$result{rcondition} = $rcond; |
4709
|
|
|
|
|
|
|
$result{ferror} = $ferr; |
4710
|
|
|
|
|
|
|
$result{berror} = $berr; |
4711
|
|
|
|
|
|
|
if ($opt{equilibrate}){ |
4712
|
|
|
|
|
|
|
$result{equilibration} = $equed; |
4713
|
|
|
|
|
|
|
if ($equed){ |
4714
|
|
|
|
|
|
|
$result{scale} = $s if $equed; |
4715
|
|
|
|
|
|
|
$result{A} = $a if $opt{A}; |
4716
|
|
|
|
|
|
|
$result{B} = $b->xchg(-2,-1)->sever if $opt{B}; |
4717
|
|
|
|
|
|
|
} |
4718
|
|
|
|
|
|
|
} |
4719
|
|
|
|
|
|
|
$result{info} = $info; |
4720
|
|
|
|
|
|
|
$result{L} = $af if $opt{L}; |
4721
|
|
|
|
|
|
|
$result{U} = $af if $opt{U}; |
4722
|
|
|
|
|
|
|
|
4723
|
|
|
|
|
|
|
wantarray ? ($x->xchg(-2,-1)->sever, %result): $x->xchg(-2,-1)->sever; |
4724
|
|
|
|
|
|
|
|
4725
|
|
|
|
|
|
|
} |
4726
|
|
|
|
|
|
|
|
4727
|
|
|
|
|
|
|
=head2 mlls |
4728
|
|
|
|
|
|
|
|
4729
|
|
|
|
|
|
|
=for ref |
4730
|
|
|
|
|
|
|
|
4731
|
|
|
|
|
|
|
Solves overdetermined or underdetermined real linear systems using QR or LQ factorization. |
4732
|
|
|
|
|
|
|
|
4733
|
|
|
|
|
|
|
If M > N in the M-by-N matrix A, returns the residual sum of squares too. |
4734
|
|
|
|
|
|
|
Uses L or L from Lapack. |
4735
|
|
|
|
|
|
|
Works on transposed arrays. |
4736
|
|
|
|
|
|
|
|
4737
|
|
|
|
|
|
|
=for usage |
4738
|
|
|
|
|
|
|
|
4739
|
|
|
|
|
|
|
PDL(X) = mlls(PDL(A), PDL(B), SCALAR(trans)) |
4740
|
|
|
|
|
|
|
trans : NOTRANSPOSE = 0 | TRANSPOSE/CONJUGATE = 1, default = 0 |
4741
|
|
|
|
|
|
|
|
4742
|
|
|
|
|
|
|
=for example |
4743
|
|
|
|
|
|
|
|
4744
|
|
|
|
|
|
|
$a = random(4,5); |
4745
|
|
|
|
|
|
|
$b = random(3,5); |
4746
|
|
|
|
|
|
|
($x, $res) = mlls($a, $b); |
4747
|
|
|
|
|
|
|
|
4748
|
|
|
|
|
|
|
=cut |
4749
|
|
|
|
|
|
|
|
4750
|
|
|
|
|
|
|
*mlls = \&PDL::mlls; |
4751
|
|
|
|
|
|
|
|
4752
|
|
|
|
|
|
|
sub PDL::mlls { |
4753
|
|
|
|
|
|
|
my($a, $b, $trans) = @_; |
4754
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4755
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4756
|
|
|
|
|
|
|
my ($info, $x, $type); |
4757
|
|
|
|
|
|
|
|
4758
|
|
|
|
|
|
|
barf("mlls: Require a matrix") |
4759
|
|
|
|
|
|
|
unless( @adims == 2 || @adims == 3); |
4760
|
|
|
|
|
|
|
barf("mlls: Require a 2D right hand side matrix B with number". |
4761
|
|
|
|
|
|
|
" of rows equal to number of rows of A") |
4762
|
|
|
|
|
|
|
unless( (@bdims == 2 || @bdims == 3)&& $bdims[-1] == $adims[-1]); |
4763
|
|
|
|
|
|
|
|
4764
|
|
|
|
|
|
|
$a = $a->copy; |
4765
|
|
|
|
|
|
|
$type = $a->type; |
4766
|
|
|
|
|
|
|
if ( $adims[-1] < $adims[-2]){ |
4767
|
|
|
|
|
|
|
if (@adims == 3){ |
4768
|
|
|
|
|
|
|
$x = PDL::new_from_specification('PDL::Complex', $type, 2,$adims[1], $bdims[1]); |
4769
|
|
|
|
|
|
|
$x(, :($bdims[2]-1), :($bdims[1]-1)) .= $b->xchg(1,2); |
4770
|
|
|
|
|
|
|
} |
4771
|
|
|
|
|
|
|
else{ |
4772
|
|
|
|
|
|
|
$x = PDL::new_from_specification('PDL', $type, $adims[0], $bdims[0]); |
4773
|
|
|
|
|
|
|
$x(:($bdims[1]-1), :($bdims[0]-1)) .= $b->xchg(0,1); |
4774
|
|
|
|
|
|
|
} |
4775
|
|
|
|
|
|
|
} |
4776
|
|
|
|
|
|
|
else{ |
4777
|
|
|
|
|
|
|
$x = $b->xchg(-2,-1)->copy; |
4778
|
|
|
|
|
|
|
} |
4779
|
|
|
|
|
|
|
$info = pdl(long,0); |
4780
|
|
|
|
|
|
|
|
4781
|
|
|
|
|
|
|
if (@adims == 3){ |
4782
|
|
|
|
|
|
|
$trans ? $a->xchg(1,2)->cgels(1, $x, $info) : $a->xchg(1,2)->cgels(0, $x, $info); |
4783
|
|
|
|
|
|
|
} |
4784
|
|
|
|
|
|
|
else{ |
4785
|
|
|
|
|
|
|
$trans ? $a->gels(0, $x, $info) : $a->gels(1, $x, $info); |
4786
|
|
|
|
|
|
|
} |
4787
|
|
|
|
|
|
|
|
4788
|
|
|
|
|
|
|
$x = $x->xchg(-2,-1); |
4789
|
|
|
|
|
|
|
if ( $adims[-1] <= $adims[-2]){ |
4790
|
|
|
|
|
|
|
return $x->sever; |
4791
|
|
|
|
|
|
|
} |
4792
|
|
|
|
|
|
|
|
4793
|
|
|
|
|
|
|
|
4794
|
|
|
|
|
|
|
if(@adims == 2){ |
4795
|
|
|
|
|
|
|
wantarray ? return($x(, :($adims[0]-1))->sever, $x(, $adims[0]:)->xchg(0,1)->pow(2)->sumover) : |
4796
|
|
|
|
|
|
|
return $x(, :($adims[0]-1))->sever; |
4797
|
|
|
|
|
|
|
} |
4798
|
|
|
|
|
|
|
else{ |
4799
|
|
|
|
|
|
|
wantarray ? return($x(,, :($adims[1]-1))->sever, PDL::Ufunc::sumover(PDL::Complex::Cpow($x(,, $adims[1]:),pdl($type,2,0))->reorder(2,0,1))) : |
4800
|
|
|
|
|
|
|
return $x(,, :($adims[1]-1))->sever; |
4801
|
|
|
|
|
|
|
} |
4802
|
|
|
|
|
|
|
} |
4803
|
|
|
|
|
|
|
|
4804
|
|
|
|
|
|
|
=head2 mllsy |
4805
|
|
|
|
|
|
|
|
4806
|
|
|
|
|
|
|
=for ref |
4807
|
|
|
|
|
|
|
|
4808
|
|
|
|
|
|
|
Computes the minimum-norm solution to a real linear least squares problem |
4809
|
|
|
|
|
|
|
using a complete orthogonal factorization. |
4810
|
|
|
|
|
|
|
|
4811
|
|
|
|
|
|
|
Uses L or L |
4812
|
|
|
|
|
|
|
from Lapack. Works on tranposed arrays. |
4813
|
|
|
|
|
|
|
|
4814
|
|
|
|
|
|
|
=for usage |
4815
|
|
|
|
|
|
|
|
4816
|
|
|
|
|
|
|
( PDL(X), ( HASH(result) ) ) = mllsy(PDL(A), PDL(B)) |
4817
|
|
|
|
|
|
|
Returned values: |
4818
|
|
|
|
|
|
|
X (SCALAR CONTEXT), |
4819
|
|
|
|
|
|
|
HASH{'A'}: |
4820
|
|
|
|
|
|
|
complete orthogonal factorization of A |
4821
|
|
|
|
|
|
|
HASH{'jpvt'}: |
4822
|
|
|
|
|
|
|
details of columns interchanges |
4823
|
|
|
|
|
|
|
HASH{'rank'}: |
4824
|
|
|
|
|
|
|
effective rank of A |
4825
|
|
|
|
|
|
|
|
4826
|
|
|
|
|
|
|
=for example |
4827
|
|
|
|
|
|
|
|
4828
|
|
|
|
|
|
|
my $a = random(10,10); |
4829
|
|
|
|
|
|
|
my $b = random(10,10); |
4830
|
|
|
|
|
|
|
$X = mllsy($a, $b); |
4831
|
|
|
|
|
|
|
|
4832
|
|
|
|
|
|
|
=cut |
4833
|
|
|
|
|
|
|
|
4834
|
|
|
|
|
|
|
*mllsy = \&PDL::mllsy; |
4835
|
|
|
|
|
|
|
|
4836
|
|
|
|
|
|
|
sub PDL::mllsy { |
4837
|
|
|
|
|
|
|
my($a, $b) = @_; |
4838
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4839
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4840
|
|
|
|
|
|
|
my ($info, $x, $rcond, $rank, $jpvt, $type); |
4841
|
|
|
|
|
|
|
|
4842
|
|
|
|
|
|
|
barf("mllsy: Require a matrix") |
4843
|
|
|
|
|
|
|
unless( @adims == 2 || @adims == 3); |
4844
|
|
|
|
|
|
|
barf("mllsy: Require a 2D right hand side matrix B with number". |
4845
|
|
|
|
|
|
|
" of rows equal to number of rows of A") |
4846
|
|
|
|
|
|
|
unless( (@bdims == 2 || @bdims == 3)&& $bdims[-1] == $adims[-1]); |
4847
|
|
|
|
|
|
|
|
4848
|
|
|
|
|
|
|
$type = $a->type; |
4849
|
|
|
|
|
|
|
$rcond = lamch(pdl($type,0)); |
4850
|
|
|
|
|
|
|
$rcond = $rcond->sqrt - ($rcond->sqrt - $rcond) / 2; |
4851
|
|
|
|
|
|
|
|
4852
|
|
|
|
|
|
|
$a = $a->xchg(-2,-1)->copy; |
4853
|
|
|
|
|
|
|
|
4854
|
|
|
|
|
|
|
if ( $adims[1] < $adims[0]){ |
4855
|
|
|
|
|
|
|
if (@adims == 3){ |
4856
|
|
|
|
|
|
|
$x = PDL::new_from_specification('PDL::Complex', $type, 2, $adims[1], $bdims[1]); |
4857
|
|
|
|
|
|
|
$x(, :($bdims[2]-1), :($bdims[1]-1)) .= $b->xchg(1,2); |
4858
|
|
|
|
|
|
|
} |
4859
|
|
|
|
|
|
|
else{ |
4860
|
|
|
|
|
|
|
$x = PDL::new_from_specification('PDL', $type, $adims[0], $bdims[0]); |
4861
|
|
|
|
|
|
|
$x(:($bdims[1]-1), :($bdims[0]-1)) .= $b->xchg(0,1); |
4862
|
|
|
|
|
|
|
} |
4863
|
|
|
|
|
|
|
|
4864
|
|
|
|
|
|
|
} |
4865
|
|
|
|
|
|
|
else{ |
4866
|
|
|
|
|
|
|
$x = $b->xchg(-2,-1)->copy; |
4867
|
|
|
|
|
|
|
} |
4868
|
|
|
|
|
|
|
$info = pdl(long,0); |
4869
|
|
|
|
|
|
|
$rank = null; |
4870
|
|
|
|
|
|
|
$jpvt = zeroes(long, $adims[-2]); |
4871
|
|
|
|
|
|
|
|
4872
|
|
|
|
|
|
|
(@adims == 3) ? $a->cgelsy($x, $rcond, $jpvt, $rank, $info) : |
4873
|
|
|
|
|
|
|
$a->gelsy($x, $rcond, $jpvt, $rank, $info); |
4874
|
|
|
|
|
|
|
|
4875
|
|
|
|
|
|
|
if ( $adims[-1] <= $adims[-2]){ |
4876
|
|
|
|
|
|
|
wantarray ? return ($x->xchg(-2,-1)->sever, ('A'=> $a->xchg(-2,-1)->sever, 'rank' => $rank, 'jpvt'=>$jpvt)) : |
4877
|
|
|
|
|
|
|
return $x->xchg(-2,-1)->sever; |
4878
|
|
|
|
|
|
|
} |
4879
|
|
|
|
|
|
|
if (@adims == 3){ |
4880
|
|
|
|
|
|
|
wantarray ? return ($x->xchg(1,2)->(,, :($adims[1]-1))->sever, ('A'=> $a->xchg(1,2)->sever, 'rank' => $rank, 'jpvt'=>$jpvt)) : |
4881
|
|
|
|
|
|
|
$x->xchg(1,2)->(, :($adims[1]-1))->sever; |
4882
|
|
|
|
|
|
|
} |
4883
|
|
|
|
|
|
|
else{ |
4884
|
|
|
|
|
|
|
wantarray ? return ($x->xchg(0,1)->(, :($adims[0]-1))->sever, ('A'=> $a->xchg(0,1)->sever, 'rank' => $rank, 'jpvt'=>$jpvt)) : |
4885
|
|
|
|
|
|
|
$x->xchg(0,1)->(, :($adims[0]-1))->sever; |
4886
|
|
|
|
|
|
|
} |
4887
|
|
|
|
|
|
|
} |
4888
|
|
|
|
|
|
|
|
4889
|
|
|
|
|
|
|
=head2 mllss |
4890
|
|
|
|
|
|
|
|
4891
|
|
|
|
|
|
|
=for ref |
4892
|
|
|
|
|
|
|
|
4893
|
|
|
|
|
|
|
Computes the minimum-norm solution to a real linear least squares problem |
4894
|
|
|
|
|
|
|
using a singular value decomposition. |
4895
|
|
|
|
|
|
|
|
4896
|
|
|
|
|
|
|
Uses L or L from Lapack. |
4897
|
|
|
|
|
|
|
Works on transposed arrays. |
4898
|
|
|
|
|
|
|
|
4899
|
|
|
|
|
|
|
=for usage |
4900
|
|
|
|
|
|
|
|
4901
|
|
|
|
|
|
|
( PDL(X), ( HASH(result) ) )= mllss(PDL(A), PDL(B), SCALAR(method)) |
4902
|
|
|
|
|
|
|
method: specifie which method to use (see Lapack for further details) |
4903
|
|
|
|
|
|
|
'(c)gelss' or '(c)gelsd', default = '(c)gelsd' |
4904
|
|
|
|
|
|
|
Returned values: |
4905
|
|
|
|
|
|
|
X (SCALAR CONTEXT), |
4906
|
|
|
|
|
|
|
HASH{'V'}: |
4907
|
|
|
|
|
|
|
if method = (c)gelss, the right singular vectors, stored columnwise |
4908
|
|
|
|
|
|
|
HASH{'s'}: |
4909
|
|
|
|
|
|
|
singular values from SVD |
4910
|
|
|
|
|
|
|
HASH{'res'}: |
4911
|
|
|
|
|
|
|
if A has full rank the residual sum-of-squares for the solution |
4912
|
|
|
|
|
|
|
HASH{'rank'}: |
4913
|
|
|
|
|
|
|
effective rank of A |
4914
|
|
|
|
|
|
|
HASH{'info'}: |
4915
|
|
|
|
|
|
|
info output from method |
4916
|
|
|
|
|
|
|
|
4917
|
|
|
|
|
|
|
=for example |
4918
|
|
|
|
|
|
|
|
4919
|
|
|
|
|
|
|
my $a = random(10,10); |
4920
|
|
|
|
|
|
|
my $b = random(10,10); |
4921
|
|
|
|
|
|
|
$X = mllss($a, $b); |
4922
|
|
|
|
|
|
|
|
4923
|
|
|
|
|
|
|
=cut |
4924
|
|
|
|
|
|
|
|
4925
|
|
|
|
|
|
|
*mllss = \&PDL::mllss; |
4926
|
|
|
|
|
|
|
|
4927
|
|
|
|
|
|
|
sub PDL::mllss { |
4928
|
|
|
|
|
|
|
my($a, $b, $method) = @_; |
4929
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
4930
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
4931
|
|
|
|
|
|
|
my ($info, $x, $rcond, $rank, $s, $min, $type); |
4932
|
|
|
|
|
|
|
|
4933
|
|
|
|
|
|
|
barf("mllss: Require a matrix") |
4934
|
|
|
|
|
|
|
unless( @adims == 2 || @adims == 3); |
4935
|
|
|
|
|
|
|
barf("mllss: Require a 2D right hand side matrix B with number". |
4936
|
|
|
|
|
|
|
" of rows equal to number of rows of A") |
4937
|
|
|
|
|
|
|
unless( (@bdims == 2 || @bdims == 3)&& $bdims[-1] == $adims[-1]); |
4938
|
|
|
|
|
|
|
|
4939
|
|
|
|
|
|
|
|
4940
|
|
|
|
|
|
|
$type = $a->type; |
4941
|
|
|
|
|
|
|
#TODO: Add this in option |
4942
|
|
|
|
|
|
|
$rcond = lamch(pdl($type,0)); |
4943
|
|
|
|
|
|
|
$rcond = $rcond->sqrt - ($rcond->sqrt - $rcond) / 2; |
4944
|
|
|
|
|
|
|
|
4945
|
|
|
|
|
|
|
$a = $a->xchg(-2,-1)->copy; |
4946
|
|
|
|
|
|
|
|
4947
|
|
|
|
|
|
|
if ($adims[1] < $adims[0]){ |
4948
|
|
|
|
|
|
|
if (@adims == 3){ |
4949
|
|
|
|
|
|
|
$x = PDL::new_from_specification('PDL::Complex', $type, 2, $adims[1], $bdims[1]); |
4950
|
|
|
|
|
|
|
$x(, :($bdims[2]-1), :($bdims[1]-1)) .= $b->xchg(1,2); |
4951
|
|
|
|
|
|
|
} |
4952
|
|
|
|
|
|
|
else{ |
4953
|
|
|
|
|
|
|
$x = PDL::new_from_specification('PDL', $type, $adims[0], $bdims[0]); |
4954
|
|
|
|
|
|
|
$x(:($bdims[1]-1), :($bdims[0]-1)) .= $b->xchg(0,1); |
4955
|
|
|
|
|
|
|
} |
4956
|
|
|
|
|
|
|
|
4957
|
|
|
|
|
|
|
} |
4958
|
|
|
|
|
|
|
else{ |
4959
|
|
|
|
|
|
|
$x = $b->xchg(-2,-1)->copy; |
4960
|
|
|
|
|
|
|
} |
4961
|
|
|
|
|
|
|
|
4962
|
|
|
|
|
|
|
$info = pdl(long,0); |
4963
|
|
|
|
|
|
|
$rank = null; |
4964
|
|
|
|
|
|
|
$min = ($adims[-2] > $adims[-1]) ? $adims[-1] : $adims[-2]; |
4965
|
|
|
|
|
|
|
$s = zeroes($a->type, $min); |
4966
|
|
|
|
|
|
|
|
4967
|
|
|
|
|
|
|
unless ($method) { |
4968
|
|
|
|
|
|
|
$method = (@adims == 3) ? 'cgelsd' : 'gelsd'; |
4969
|
|
|
|
|
|
|
} |
4970
|
|
|
|
|
|
|
|
4971
|
|
|
|
|
|
|
$a->$method($x, $rcond, $s, $rank, $info); |
4972
|
|
|
|
|
|
|
laerror("mllss: The algorithm for computing the SVD failed to converge\n") if $info; |
4973
|
|
|
|
|
|
|
|
4974
|
|
|
|
|
|
|
$x = $x->xchg(-2,-1); |
4975
|
|
|
|
|
|
|
|
4976
|
|
|
|
|
|
|
if ( $adims[-1] <= $adims[-2]){ |
4977
|
|
|
|
|
|
|
if (wantarray){ |
4978
|
|
|
|
|
|
|
$method =~ /gelsd/ ? return ($x->sever, ('rank' => $rank, 's'=>$s, 'info'=>$info)): |
4979
|
|
|
|
|
|
|
(return ($x, ('V'=> $a, 'rank' => $rank, 's'=>$s, 'info'=>$info)) ); |
4980
|
|
|
|
|
|
|
} |
4981
|
|
|
|
|
|
|
else{return $x;} |
4982
|
|
|
|
|
|
|
} |
4983
|
|
|
|
|
|
|
elsif (wantarray){ |
4984
|
|
|
|
|
|
|
if ($rank == $min){ |
4985
|
|
|
|
|
|
|
if (@adims == 3){ |
4986
|
|
|
|
|
|
|
my $res = PDL::Ufunc::sumover(PDL::Complex::Cpow($x(,, $adims[1]:),pdl($type,2,0))->reorder(2,0,1)); |
4987
|
|
|
|
|
|
|
if ($method =~ /gelsd/){ |
4988
|
|
|
|
|
|
|
|
4989
|
|
|
|
|
|
|
return ($x(,, :($adims[1]-1))->sever, |
4990
|
|
|
|
|
|
|
('res' => $res, 'rank' => $rank, 's'=>$s, 'info'=>$info)); |
4991
|
|
|
|
|
|
|
} |
4992
|
|
|
|
|
|
|
else{ |
4993
|
|
|
|
|
|
|
return ($x(,, :($adims[1]-1))->sever, |
4994
|
|
|
|
|
|
|
('res' => $res, 'V'=> $a, 'rank' => $rank, 's'=>$s, 'info'=>$info)); |
4995
|
|
|
|
|
|
|
} |
4996
|
|
|
|
|
|
|
} |
4997
|
|
|
|
|
|
|
else{ |
4998
|
|
|
|
|
|
|
my $res = $x(, $adims[0]:)->xchg(0,1)->pow(2)->sumover; |
4999
|
|
|
|
|
|
|
if ($method =~ /gelsd/){ |
5000
|
|
|
|
|
|
|
|
5001
|
|
|
|
|
|
|
return ($x(, :($adims[0]-1))->sever, |
5002
|
|
|
|
|
|
|
('res' => $res, 'rank' => $rank, 's'=>$s, 'info'=>$info)); |
5003
|
|
|
|
|
|
|
} |
5004
|
|
|
|
|
|
|
else{ |
5005
|
|
|
|
|
|
|
return ($x(, :($adims[0]-1))->sever, |
5006
|
|
|
|
|
|
|
('res' => $res, 'V'=> $a, 'rank' => $rank, 's'=>$s, 'info'=>$info)); |
5007
|
|
|
|
|
|
|
} |
5008
|
|
|
|
|
|
|
} |
5009
|
|
|
|
|
|
|
} |
5010
|
|
|
|
|
|
|
else { |
5011
|
|
|
|
|
|
|
if (@adims == 3){ |
5012
|
|
|
|
|
|
|
$method =~ /gelsd/ ? return ($x(,, :($adims[1]-1))->sever, ('rank' => $rank, 's'=>$s, 'info'=>$info)) |
5013
|
|
|
|
|
|
|
: ($x(,, :($adims[1]-1))->sever, ('v'=> $a, 'rank' => $rank, 's'=>$s, 'info'=>$info)); |
5014
|
|
|
|
|
|
|
} |
5015
|
|
|
|
|
|
|
else{ |
5016
|
|
|
|
|
|
|
$method =~ /gelsd/ ? return ($x(, :($adims[0]-1))->sever, ('rank' => $rank, 's'=>$s, 'info'=>$info)) |
5017
|
|
|
|
|
|
|
: ($x(, :($adims[0]-1))->sever, ('v'=> $a, 'rank' => $rank, 's'=>$s, 'info'=>$info)); |
5018
|
|
|
|
|
|
|
} |
5019
|
|
|
|
|
|
|
} |
5020
|
|
|
|
|
|
|
|
5021
|
|
|
|
|
|
|
} |
5022
|
|
|
|
|
|
|
else{return (@adims == 3) ? $x(,, :($adims[1]-1))->sever : $x(, :($adims[0]-1))->sever;} |
5023
|
|
|
|
|
|
|
} |
5024
|
|
|
|
|
|
|
|
5025
|
|
|
|
|
|
|
=head2 mglm |
5026
|
|
|
|
|
|
|
|
5027
|
|
|
|
|
|
|
=for ref |
5028
|
|
|
|
|
|
|
|
5029
|
|
|
|
|
|
|
Solves a general Gauss-Markov Linear Model (GLM) problem. |
5030
|
|
|
|
|
|
|
Supports threading. |
5031
|
|
|
|
|
|
|
Uses L or L |
5032
|
|
|
|
|
|
|
from Lapack. Works on transposed arrays. |
5033
|
|
|
|
|
|
|
|
5034
|
|
|
|
|
|
|
=for usage |
5035
|
|
|
|
|
|
|
|
5036
|
|
|
|
|
|
|
(PDL(x), PDL(y)) = mglm(PDL(a), PDL(b), PDL(d)) |
5037
|
|
|
|
|
|
|
where d is the left hand side of the GLM equation |
5038
|
|
|
|
|
|
|
|
5039
|
|
|
|
|
|
|
=for example |
5040
|
|
|
|
|
|
|
|
5041
|
|
|
|
|
|
|
my $a = random(8,10); |
5042
|
|
|
|
|
|
|
my $b = random(7,10); |
5043
|
|
|
|
|
|
|
my $d = random(10); |
5044
|
|
|
|
|
|
|
my ($x, $y) = mglm($a, $b, $d); |
5045
|
|
|
|
|
|
|
|
5046
|
|
|
|
|
|
|
=cut |
5047
|
|
|
|
|
|
|
|
5048
|
|
|
|
|
|
|
sub mglm{ |
5049
|
|
|
|
|
|
|
my $m = shift; |
5050
|
|
|
|
|
|
|
$m->mglm(@_); |
5051
|
|
|
|
|
|
|
} |
5052
|
|
|
|
|
|
|
|
5053
|
|
|
|
|
|
|
sub PDL::mglm{ |
5054
|
|
|
|
|
|
|
my($a, $b, $d) = @_; |
5055
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
5056
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
5057
|
|
|
|
|
|
|
my(@ddims) = $d->dims; |
5058
|
|
|
|
|
|
|
my($x, $y, $info); |
5059
|
|
|
|
|
|
|
|
5060
|
|
|
|
|
|
|
barf("mglm: Require arrays with equal number of rows") |
5061
|
|
|
|
|
|
|
unless( @adims >= 2 && @bdims >= 2 && $adims[1] == $bdims[1]); |
5062
|
|
|
|
|
|
|
|
5063
|
|
|
|
|
|
|
barf "mglm: Require that column(A) <= row(A) <= column(A) + column(B)" unless |
5064
|
|
|
|
|
|
|
( ($adims[0] <= $adims[1] ) && ($adims[1] <= ($adims[0] + $bdims[0])) ); |
5065
|
|
|
|
|
|
|
|
5066
|
|
|
|
|
|
|
barf("mglm: Require vector(s) with size equal to number of rows of A") |
5067
|
|
|
|
|
|
|
unless( @ddims >= 1 && $adims[1] == $ddims[0]); |
5068
|
|
|
|
|
|
|
|
5069
|
|
|
|
|
|
|
$a = $a->xchg(0,1)->copy; |
5070
|
|
|
|
|
|
|
$b = $b->xchg(0,1)->copy; |
5071
|
|
|
|
|
|
|
$d = $d->copy; |
5072
|
|
|
|
|
|
|
|
5073
|
|
|
|
|
|
|
($x, $y, $info) = $a->ggglm($b, $d); |
5074
|
|
|
|
|
|
|
$x, $y; |
5075
|
|
|
|
|
|
|
|
5076
|
|
|
|
|
|
|
} |
5077
|
|
|
|
|
|
|
|
5078
|
|
|
|
|
|
|
sub PDL::Complex::mglm { |
5079
|
|
|
|
|
|
|
my($a, $b, $d) = @_; |
5080
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
5081
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
5082
|
|
|
|
|
|
|
my(@ddims) = $d->dims; |
5083
|
|
|
|
|
|
|
my($x, $y, $info); |
5084
|
|
|
|
|
|
|
|
5085
|
|
|
|
|
|
|
barf("mglm: Require arrays with equal number of rows") |
5086
|
|
|
|
|
|
|
unless( @adims >= 3 && @bdims >= 3 && $adims[2] == $bdims[2]); |
5087
|
|
|
|
|
|
|
|
5088
|
|
|
|
|
|
|
barf "mglm: Require that column(A) <= row(A) <= column(A) + column(B)" unless |
5089
|
|
|
|
|
|
|
( ($adims[2] <= $adims[2] ) && ($adims[2] <= ($adims[1] + $bdims[1])) ); |
5090
|
|
|
|
|
|
|
|
5091
|
|
|
|
|
|
|
barf("mglm: Require vector(s) with size equal to number of rows of A") |
5092
|
|
|
|
|
|
|
unless( @ddims >= 2 && $adims[2] == $ddims[1]); |
5093
|
|
|
|
|
|
|
|
5094
|
|
|
|
|
|
|
|
5095
|
|
|
|
|
|
|
$a = $a->xchg(1,2)->copy; |
5096
|
|
|
|
|
|
|
$b = $b->xchg(1,2)->copy; |
5097
|
|
|
|
|
|
|
$d = $d->copy; |
5098
|
|
|
|
|
|
|
|
5099
|
|
|
|
|
|
|
($x, $y, $info) = $a->cggglm($b, $d); |
5100
|
|
|
|
|
|
|
$x, $y; |
5101
|
|
|
|
|
|
|
|
5102
|
|
|
|
|
|
|
} |
5103
|
|
|
|
|
|
|
|
5104
|
|
|
|
|
|
|
|
5105
|
|
|
|
|
|
|
=head2 mlse |
5106
|
|
|
|
|
|
|
|
5107
|
|
|
|
|
|
|
=for ref |
5108
|
|
|
|
|
|
|
|
5109
|
|
|
|
|
|
|
Solves a linear equality-constrained least squares (LSE) problem. |
5110
|
|
|
|
|
|
|
Uses L or L |
5111
|
|
|
|
|
|
|
from Lapack. Works on transposed arrays. |
5112
|
|
|
|
|
|
|
|
5113
|
|
|
|
|
|
|
=for usage |
5114
|
|
|
|
|
|
|
|
5115
|
|
|
|
|
|
|
(PDL(x), PDL(res2)) = mlse(PDL(a), PDL(b), PDL(c), PDL(d)) |
5116
|
|
|
|
|
|
|
where |
5117
|
|
|
|
|
|
|
c : The right hand side vector for the |
5118
|
|
|
|
|
|
|
least squares part of the LSE problem. |
5119
|
|
|
|
|
|
|
d : The right hand side vector for the |
5120
|
|
|
|
|
|
|
constrained equation. |
5121
|
|
|
|
|
|
|
x : The solution of the LSE problem. |
5122
|
|
|
|
|
|
|
res2 : The residual sum of squares for the solution |
5123
|
|
|
|
|
|
|
(returned only in array context) |
5124
|
|
|
|
|
|
|
|
5125
|
|
|
|
|
|
|
|
5126
|
|
|
|
|
|
|
=for example |
5127
|
|
|
|
|
|
|
|
5128
|
|
|
|
|
|
|
my $a = random(5,4); |
5129
|
|
|
|
|
|
|
my $b = random(5,3); |
5130
|
|
|
|
|
|
|
my $c = random(4); |
5131
|
|
|
|
|
|
|
my $d = random(3); |
5132
|
|
|
|
|
|
|
my ($x, $res2) = mlse($a, $b, $c, $d); |
5133
|
|
|
|
|
|
|
|
5134
|
|
|
|
|
|
|
=cut |
5135
|
|
|
|
|
|
|
|
5136
|
|
|
|
|
|
|
*mlse = \&PDL::mlse; |
5137
|
|
|
|
|
|
|
|
5138
|
|
|
|
|
|
|
sub PDL::mlse { |
5139
|
|
|
|
|
|
|
my($a, $b, $c, $d) = @_; |
5140
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
5141
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
5142
|
|
|
|
|
|
|
my(@cdims) = $c->dims; |
5143
|
|
|
|
|
|
|
my(@ddims) = $d->dims; |
5144
|
|
|
|
|
|
|
|
5145
|
|
|
|
|
|
|
my($x, $info); |
5146
|
|
|
|
|
|
|
|
5147
|
|
|
|
|
|
|
barf("mlse: Require 2 matrices with equal number of columns") |
5148
|
|
|
|
|
|
|
unless( ((@adims == 2 && @bdims == 2)||(@adims == 3 && @bdims == 3)) && |
5149
|
|
|
|
|
|
|
$adims[-2] == $bdims[-2]); |
5150
|
|
|
|
|
|
|
|
5151
|
|
|
|
|
|
|
barf("mlse: Require 1D vector C with size equal to number of A rows") |
5152
|
|
|
|
|
|
|
unless( (@cdims == 1 || @cdims == 2)&& $adims[-1] == $cdims[-1]); |
5153
|
|
|
|
|
|
|
|
5154
|
|
|
|
|
|
|
barf("mlse: Require 1D vector D with size equal to number of B rows") |
5155
|
|
|
|
|
|
|
unless( (@ddims == 1 || @ddims == 2)&& $bdims[-1] == $ddims[-1]); |
5156
|
|
|
|
|
|
|
|
5157
|
|
|
|
|
|
|
barf "mlse: Require that row(B) <= column(A) <= row(A) + row(B)" unless |
5158
|
|
|
|
|
|
|
( ($bdims[-1] <= $adims[-2] ) && ($adims[-2] <= ($adims[-1]+ $bdims[-1])) ); |
5159
|
|
|
|
|
|
|
|
5160
|
|
|
|
|
|
|
|
5161
|
|
|
|
|
|
|
|
5162
|
|
|
|
|
|
|
$a = $a->xchg(-2,-1)->copy; |
5163
|
|
|
|
|
|
|
$b = $b->xchg(-2,-1)->copy; |
5164
|
|
|
|
|
|
|
$c = $c->copy; |
5165
|
|
|
|
|
|
|
$d = $d->copy; |
5166
|
|
|
|
|
|
|
($x , $info) = (@adims == 3) ? $a->cgglse($b, $c, $d) : $a->gglse($b, $c, $d); |
5167
|
|
|
|
|
|
|
|
5168
|
|
|
|
|
|
|
if (@adims == 3){ |
5169
|
|
|
|
|
|
|
wantarray ? ($x, PDL::Ufunc::sumover(PDL::Complex::Cpow($c(,($adims[1]-$bdims[2]):($adims[2]-1)),pdl($a->type,2,0))->xchg(0,1))) : $x; |
5170
|
|
|
|
|
|
|
} |
5171
|
|
|
|
|
|
|
else{ |
5172
|
|
|
|
|
|
|
wantarray ? ($x, $c(($adims[0]-$bdims[1]):($adims[1]-1))->pow(2)->sumover) : $x; |
5173
|
|
|
|
|
|
|
} |
5174
|
|
|
|
|
|
|
|
5175
|
|
|
|
|
|
|
} |
5176
|
|
|
|
|
|
|
|
5177
|
|
|
|
|
|
|
=head2 meigen |
5178
|
|
|
|
|
|
|
|
5179
|
|
|
|
|
|
|
=for ref |
5180
|
|
|
|
|
|
|
|
5181
|
|
|
|
|
|
|
Computes eigenvalues and, optionally, the left and/or right eigenvectors of a general square matrix |
5182
|
|
|
|
|
|
|
(spectral decomposition). |
5183
|
|
|
|
|
|
|
Eigenvectors are normalized (Euclidean norm = 1) and largest component real. |
5184
|
|
|
|
|
|
|
The eigenvalues and eigenvectors returned are object of type PDL::Complex. |
5185
|
|
|
|
|
|
|
If only eigenvalues are requested, info is returned in array context. |
5186
|
|
|
|
|
|
|
Supports threading. |
5187
|
|
|
|
|
|
|
Uses L or L from Lapack. |
5188
|
|
|
|
|
|
|
Works on transposed arrays. |
5189
|
|
|
|
|
|
|
|
5190
|
|
|
|
|
|
|
=for usage |
5191
|
|
|
|
|
|
|
|
5192
|
|
|
|
|
|
|
(PDL(values), (PDL(LV), (PDL(RV)), (PDL(info))) = meigen(PDL, SCALAR(left vector), SCALAR(right vector)) |
5193
|
|
|
|
|
|
|
left vector : FALSE = 0 | TRUE = 1, default = 0 |
5194
|
|
|
|
|
|
|
right vector : FALSE = 0 | TRUE = 1, default = 0 |
5195
|
|
|
|
|
|
|
|
5196
|
|
|
|
|
|
|
=for example |
5197
|
|
|
|
|
|
|
|
5198
|
|
|
|
|
|
|
my $a = random(10,10); |
5199
|
|
|
|
|
|
|
my ( $eigenvalues, $left_eigenvectors, $right_eigenvectors ) = meigen($a,1,1); |
5200
|
|
|
|
|
|
|
|
5201
|
|
|
|
|
|
|
=cut |
5202
|
|
|
|
|
|
|
|
5203
|
|
|
|
|
|
|
sub meigen{ |
5204
|
|
|
|
|
|
|
my $m = shift; |
5205
|
|
|
|
|
|
|
$m->meigen(@_); |
5206
|
|
|
|
|
|
|
} |
5207
|
|
|
|
|
|
|
|
5208
|
|
|
|
|
|
|
|
5209
|
|
|
|
|
|
|
sub PDL::meigen { |
5210
|
|
|
|
|
|
|
my($m,$jobvl,$jobvr) = @_; |
5211
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
5212
|
|
|
|
|
|
|
|
5213
|
|
|
|
|
|
|
barf("meigen: Require square array(s)") |
5214
|
|
|
|
|
|
|
unless( @dims >= 2 && $dims[0] == $dims[1]); |
5215
|
|
|
|
|
|
|
|
5216
|
|
|
|
|
|
|
my ($w, $vl, $vr, $info, $type, $wr, $wi); |
5217
|
|
|
|
|
|
|
$type = $m->type; |
5218
|
|
|
|
|
|
|
|
5219
|
|
|
|
|
|
|
$info = null; |
5220
|
|
|
|
|
|
|
$wr = null; |
5221
|
|
|
|
|
|
|
$wi = null; |
5222
|
|
|
|
|
|
|
|
5223
|
|
|
|
|
|
|
$vl = $jobvl ? PDL::new_from_specification('PDL', $type, @dims) : |
5224
|
|
|
|
|
|
|
pdl($type,0); |
5225
|
|
|
|
|
|
|
$vr = $jobvr ? PDL::new_from_specification('PDL', $type, @dims) : |
5226
|
|
|
|
|
|
|
pdl($type,0); |
5227
|
|
|
|
|
|
|
$m->xchg(0,1)->geev( $jobvl,$jobvr, $wr, $wi, $vl, $vr, $info); |
5228
|
|
|
|
|
|
|
if ($jobvl){ |
5229
|
|
|
|
|
|
|
($w, $vl) = cplx_eigen((bless $wr, 'PDL::Complex'), $wi, $vl, 1); |
5230
|
|
|
|
|
|
|
} |
5231
|
|
|
|
|
|
|
if ($jobvr){ |
5232
|
|
|
|
|
|
|
($w, $vr) = cplx_eigen((bless $wr, 'PDL::Complex'), $wi, $vr, 1); |
5233
|
|
|
|
|
|
|
} |
5234
|
|
|
|
|
|
|
$w = PDL::Complex::ecplx( $wr, $wi ) unless $jobvr || $jobvl; |
5235
|
|
|
|
|
|
|
|
5236
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
5237
|
|
|
|
|
|
|
my ($index,@list); |
5238
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
5239
|
|
|
|
|
|
|
@list = $index->list; |
5240
|
|
|
|
|
|
|
laerror("meigen: The QR algorithm failed to converge for PDL(s) @list: \$info = $info"); |
5241
|
|
|
|
|
|
|
print ("Returning converged eigenvalues\n"); |
5242
|
|
|
|
|
|
|
} |
5243
|
|
|
|
|
|
|
|
5244
|
|
|
|
|
|
|
$jobvl? $jobvr ? ($w, $vl->xchg(1,2)->sever, $vr->xchg(1,2)->sever, $info):($w, $vl->xchg(1,2)->sever, $info) : |
5245
|
|
|
|
|
|
|
$jobvr? ($w, $vr->xchg(1,2)->sever, $info) : wantarray ? ($w, $info) : $w; |
5246
|
|
|
|
|
|
|
|
5247
|
|
|
|
|
|
|
} |
5248
|
|
|
|
|
|
|
|
5249
|
|
|
|
|
|
|
sub PDL::Complex::meigen { |
5250
|
|
|
|
|
|
|
my($m,$jobvl,$jobvr) = @_; |
5251
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
5252
|
|
|
|
|
|
|
|
5253
|
|
|
|
|
|
|
barf("meigen: Require square array(s)") |
5254
|
|
|
|
|
|
|
unless( @dims >= 3 && $dims[1] == $dims[2]); |
5255
|
|
|
|
|
|
|
|
5256
|
|
|
|
|
|
|
my ($w, $vl, $vr, $info, $type); |
5257
|
|
|
|
|
|
|
$type = $m->type; |
5258
|
|
|
|
|
|
|
|
5259
|
|
|
|
|
|
|
$info = null; |
5260
|
|
|
|
|
|
|
|
5261
|
|
|
|
|
|
|
$w = PDL::Complex->null; |
5262
|
|
|
|
|
|
|
#PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1]); |
5263
|
|
|
|
|
|
|
$vl = $jobvl ? PDL::new_from_specification('PDL::Complex', $type, @dims) : |
5264
|
|
|
|
|
|
|
pdl($type,[0,0]); |
5265
|
|
|
|
|
|
|
$vr = $jobvr ? PDL::new_from_specification('PDL::Complex', $type, @dims) : |
5266
|
|
|
|
|
|
|
pdl($type,[0,0]); |
5267
|
|
|
|
|
|
|
$m->xchg(1,2)->cgeev( $jobvl,$jobvr, $w, $vl, $vr, $info); |
5268
|
|
|
|
|
|
|
|
5269
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
5270
|
|
|
|
|
|
|
my ($index,@list); |
5271
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
5272
|
|
|
|
|
|
|
@list = $index->list; |
5273
|
|
|
|
|
|
|
laerror("meigen: The QR algorithm failed to converge for PDL(s) @list: \$info = $info"); |
5274
|
|
|
|
|
|
|
print ("Returning converged eigenvalues\n"); |
5275
|
|
|
|
|
|
|
} |
5276
|
|
|
|
|
|
|
|
5277
|
|
|
|
|
|
|
$jobvl? $jobvr ? ($w, $vl->xchg(1,2)->sever, $vr->xchg(1,2)->sever, $info):($w, $vl->xchg(1,2)->sever, $info) : |
5278
|
|
|
|
|
|
|
$jobvr? ($w, $vr->xchg(1,2)->sever, $info) : wantarray ? ($w, $info) : $w; |
5279
|
|
|
|
|
|
|
|
5280
|
|
|
|
|
|
|
} |
5281
|
|
|
|
|
|
|
|
5282
|
|
|
|
|
|
|
|
5283
|
|
|
|
|
|
|
=head2 meigenx |
5284
|
|
|
|
|
|
|
|
5285
|
|
|
|
|
|
|
=for ref |
5286
|
|
|
|
|
|
|
|
5287
|
|
|
|
|
|
|
Computes eigenvalues, one-norm and, optionally, the left and/or right eigenvectors of a general square matrix |
5288
|
|
|
|
|
|
|
(spectral decomposition). |
5289
|
|
|
|
|
|
|
Eigenvectors are normalized (Euclidean norm = 1) and largest component real. |
5290
|
|
|
|
|
|
|
The eigenvalues and eigenvectors returned are object of type PDL::Complex. |
5291
|
|
|
|
|
|
|
Uses L or |
5292
|
|
|
|
|
|
|
L from Lapack. |
5293
|
|
|
|
|
|
|
Works on transposed arrays. |
5294
|
|
|
|
|
|
|
|
5295
|
|
|
|
|
|
|
=for usage |
5296
|
|
|
|
|
|
|
|
5297
|
|
|
|
|
|
|
(PDL(value), (PDL(lv), (PDL(rv)), HASH(result)), HASH(result)) = meigenx(PDL, HASH(options)) |
5298
|
|
|
|
|
|
|
where options are: |
5299
|
|
|
|
|
|
|
vector: eigenvectors to compute |
5300
|
|
|
|
|
|
|
'left': computes left eigenvectors |
5301
|
|
|
|
|
|
|
'right': computes right eigenvectors |
5302
|
|
|
|
|
|
|
'all': computes left and right eigenvectors |
5303
|
|
|
|
|
|
|
0: doesn't compute (default) |
5304
|
|
|
|
|
|
|
rcondition: reciprocal condition numbers to compute (returned in HASH{'rconde'} for eigenvalues and HASH{'rcondv'} for eigenvectors) |
5305
|
|
|
|
|
|
|
'value': computes reciprocal condition numbers for eigenvalues |
5306
|
|
|
|
|
|
|
'vector': computes reciprocal condition numbers for eigenvectors |
5307
|
|
|
|
|
|
|
'all': computes reciprocal condition numbers for eigenvalues and eigenvectors |
5308
|
|
|
|
|
|
|
0: doesn't compute (default) |
5309
|
|
|
|
|
|
|
error: specifie whether or not it computes the error bounds (returned in HASH{'eerror'} and HASH{'verror'}) |
5310
|
|
|
|
|
|
|
error bound = EPS * One-norm / rcond(e|v) |
5311
|
|
|
|
|
|
|
(reciprocal condition numbers for eigenvalues or eigenvectors must be computed). |
5312
|
|
|
|
|
|
|
1: returns error bounds |
5313
|
|
|
|
|
|
|
0: not computed |
5314
|
|
|
|
|
|
|
scale: specifie whether or not it diagonaly scales the entry matrix |
5315
|
|
|
|
|
|
|
(scale details returned in HASH : 'scale') |
5316
|
|
|
|
|
|
|
1: scales |
5317
|
|
|
|
|
|
|
0: Doesn't scale (default) |
5318
|
|
|
|
|
|
|
permute: specifie whether or not it permutes row and columns |
5319
|
|
|
|
|
|
|
(permute details returned in HASH{'balance'}) |
5320
|
|
|
|
|
|
|
1: permutes |
5321
|
|
|
|
|
|
|
0: Doesn't permute (default) |
5322
|
|
|
|
|
|
|
schur: specifie whether or not it returns the Schur form (returned in HASH{'schur'}) |
5323
|
|
|
|
|
|
|
1: returns Schur form |
5324
|
|
|
|
|
|
|
0: not returned |
5325
|
|
|
|
|
|
|
Returned values: |
5326
|
|
|
|
|
|
|
eigenvalues (SCALAR CONTEXT), |
5327
|
|
|
|
|
|
|
left eigenvectors if requested, |
5328
|
|
|
|
|
|
|
right eigenvectors if requested, |
5329
|
|
|
|
|
|
|
HASH{'norm'}: |
5330
|
|
|
|
|
|
|
One-norm of the matrix |
5331
|
|
|
|
|
|
|
HASH{'info'}: |
5332
|
|
|
|
|
|
|
Info: if > 0, the QR algorithm failed to compute all the eigenvalues |
5333
|
|
|
|
|
|
|
(see syevx for further details) |
5334
|
|
|
|
|
|
|
|
5335
|
|
|
|
|
|
|
|
5336
|
|
|
|
|
|
|
=for example |
5337
|
|
|
|
|
|
|
|
5338
|
|
|
|
|
|
|
my $a = random(10,10); |
5339
|
|
|
|
|
|
|
my %options = ( rcondition => 'all', |
5340
|
|
|
|
|
|
|
vector => 'all', |
5341
|
|
|
|
|
|
|
error => 1, |
5342
|
|
|
|
|
|
|
scale => 1, |
5343
|
|
|
|
|
|
|
permute=>1, |
5344
|
|
|
|
|
|
|
shur => 1 |
5345
|
|
|
|
|
|
|
); |
5346
|
|
|
|
|
|
|
my ( $eigenvalues, $left_eigenvectors, $right_eigenvectors, %result) = meigenx($a,%options); |
5347
|
|
|
|
|
|
|
print "Error bounds for eigenvalues:\n $eigenvalues\n are:\n". transpose($result{'eerror'}) unless $info; |
5348
|
|
|
|
|
|
|
|
5349
|
|
|
|
|
|
|
=cut |
5350
|
|
|
|
|
|
|
|
5351
|
|
|
|
|
|
|
|
5352
|
|
|
|
|
|
|
*meigenx = \&PDL::meigenx; |
5353
|
|
|
|
|
|
|
|
5354
|
|
|
|
|
|
|
sub PDL::meigenx { |
5355
|
|
|
|
|
|
|
my($m, %opt) = @_; |
5356
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
5357
|
|
|
|
|
|
|
barf("meigenx: Require a square matrix") |
5358
|
|
|
|
|
|
|
unless( ( (@dims == 2)|| (@dims == 3) )&& $dims[-1] == $dims[-2]); |
5359
|
|
|
|
|
|
|
|
5360
|
|
|
|
|
|
|
|
5361
|
|
|
|
|
|
|
my (%result, $jobvl, $jobvr, $sense, $balanc, $vr, $vl, $rconde, $rcondv, |
5362
|
|
|
|
|
|
|
$w, $info, $ilo, $ihi, $scale, $abnrm, $type); |
5363
|
|
|
|
|
|
|
|
5364
|
|
|
|
|
|
|
$type = $m->type; |
5365
|
|
|
|
|
|
|
$info = null; |
5366
|
|
|
|
|
|
|
$ilo = null; |
5367
|
|
|
|
|
|
|
$ihi = null; |
5368
|
|
|
|
|
|
|
$abnrm = null; |
5369
|
|
|
|
|
|
|
$balanc = ($opt{'permute'} && $opt{'scale'} ) ? 3 : $opt{'permute'} ? 1 : $opt{'scale'} ? 2:0; |
5370
|
|
|
|
|
|
|
|
5371
|
|
|
|
|
|
|
if (@dims == 3){ |
5372
|
|
|
|
|
|
|
$m = $m->copy; |
5373
|
|
|
|
|
|
|
$w = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1]); |
5374
|
|
|
|
|
|
|
$scale = PDL::new_from_specification('PDL', $type, $dims[1]); |
5375
|
|
|
|
|
|
|
|
5376
|
|
|
|
|
|
|
if ($opt{'vector'} eq 'left' || |
5377
|
|
|
|
|
|
|
$opt{'vector'} eq 'all' || |
5378
|
|
|
|
|
|
|
$opt{'rcondition'} ){ |
5379
|
|
|
|
|
|
|
$jobvl = 1; |
5380
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]); |
5381
|
|
|
|
|
|
|
} |
5382
|
|
|
|
|
|
|
else{ |
5383
|
|
|
|
|
|
|
$jobvl = 0; |
5384
|
|
|
|
|
|
|
$vl = pdl($type,[0,0]); |
5385
|
|
|
|
|
|
|
} |
5386
|
|
|
|
|
|
|
|
5387
|
|
|
|
|
|
|
if ($opt{'vector'} eq 'right' || |
5388
|
|
|
|
|
|
|
$opt{'vector'} eq 'all' || |
5389
|
|
|
|
|
|
|
$opt{'rcondition'} ){ |
5390
|
|
|
|
|
|
|
$jobvr = 1; |
5391
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]); |
5392
|
|
|
|
|
|
|
} |
5393
|
|
|
|
|
|
|
else{ |
5394
|
|
|
|
|
|
|
$jobvr = 0; |
5395
|
|
|
|
|
|
|
$vr = pdl($type,[0,0]); |
5396
|
|
|
|
|
|
|
} |
5397
|
|
|
|
|
|
|
|
5398
|
|
|
|
|
|
|
if ( $opt{'rcondition'} eq 'value'){ |
5399
|
|
|
|
|
|
|
$sense = 1; |
5400
|
|
|
|
|
|
|
$rconde = PDL::new_from_specification('PDL', $type, $dims[1]); |
5401
|
|
|
|
|
|
|
$rcondv = pdl($type,0); |
5402
|
|
|
|
|
|
|
} |
5403
|
|
|
|
|
|
|
elsif( $opt{'rcondition'} eq 'vector'){ |
5404
|
|
|
|
|
|
|
$sense = 2; |
5405
|
|
|
|
|
|
|
$rcondv = PDL::new_from_specification('PDL', $type, $dims[1]); |
5406
|
|
|
|
|
|
|
$rconde = pdl($type,0); |
5407
|
|
|
|
|
|
|
} |
5408
|
|
|
|
|
|
|
elsif( $opt{'rcondition'} eq 'all' ){ |
5409
|
|
|
|
|
|
|
$sense = 3; |
5410
|
|
|
|
|
|
|
$rcondv = PDL::new_from_specification('PDL', $type, $dims[1]); |
5411
|
|
|
|
|
|
|
$rconde = PDL::new_from_specification('PDL', $type, $dims[1]); |
5412
|
|
|
|
|
|
|
} |
5413
|
|
|
|
|
|
|
else{ |
5414
|
|
|
|
|
|
|
$sense = 0; |
5415
|
|
|
|
|
|
|
$rconde = pdl($type,0); |
5416
|
|
|
|
|
|
|
$rcondv = pdl($type,0); |
5417
|
|
|
|
|
|
|
} |
5418
|
|
|
|
|
|
|
$m->xchg(1,2)->cgeevx( $jobvl, $jobvr, $balanc,$sense,$w, $vl, $vr, $ilo, $ihi, $scale, $abnrm, $rconde, $rcondv, $info); |
5419
|
|
|
|
|
|
|
|
5420
|
|
|
|
|
|
|
} |
5421
|
|
|
|
|
|
|
else{ |
5422
|
|
|
|
|
|
|
my ($wr, $wi); |
5423
|
|
|
|
|
|
|
$m = $m->copy; |
5424
|
|
|
|
|
|
|
$wr = PDL::new_from_specification('PDL', $type, $dims[0]); |
5425
|
|
|
|
|
|
|
$wi = PDL::new_from_specification('PDL', $type, $dims[0]); |
5426
|
|
|
|
|
|
|
$scale = PDL::new_from_specification('PDL', $type, $dims[0]); |
5427
|
|
|
|
|
|
|
|
5428
|
|
|
|
|
|
|
if ($opt{'vector'} eq 'left' || |
5429
|
|
|
|
|
|
|
$opt{'vector'} eq 'all' || |
5430
|
|
|
|
|
|
|
$opt{'rcondition'} ){ |
5431
|
|
|
|
|
|
|
$jobvl = 1; |
5432
|
|
|
|
|
|
|
$vl = PDL::new_from_specification('PDL', $type, $dims[0], $dims[0]); |
5433
|
|
|
|
|
|
|
} |
5434
|
|
|
|
|
|
|
else{ |
5435
|
|
|
|
|
|
|
$jobvl = 0; |
5436
|
|
|
|
|
|
|
$vl = pdl($type, 0); |
5437
|
|
|
|
|
|
|
} |
5438
|
|
|
|
|
|
|
|
5439
|
|
|
|
|
|
|
if ($opt{'vector'} eq 'right' || |
5440
|
|
|
|
|
|
|
$opt{'vector'} eq 'all' || |
5441
|
|
|
|
|
|
|
$opt{'rcondition'} ){ |
5442
|
|
|
|
|
|
|
$jobvr = 1; |
5443
|
|
|
|
|
|
|
$vr = PDL::new_from_specification('PDL', $type, $dims[0], $dims[0]); |
5444
|
|
|
|
|
|
|
} |
5445
|
|
|
|
|
|
|
else{ |
5446
|
|
|
|
|
|
|
$jobvr = 0; |
5447
|
|
|
|
|
|
|
$vr = pdl($type,0); |
5448
|
|
|
|
|
|
|
} |
5449
|
|
|
|
|
|
|
|
5450
|
|
|
|
|
|
|
if ( $opt{'rcondition'} eq 'value'){ |
5451
|
|
|
|
|
|
|
$sense = 1; |
5452
|
|
|
|
|
|
|
$rconde = PDL::new_from_specification('PDL', $type, $dims[0]); |
5453
|
|
|
|
|
|
|
$rcondv = pdl($type, 0); |
5454
|
|
|
|
|
|
|
} |
5455
|
|
|
|
|
|
|
elsif( $opt{'rcondition'} eq 'vector'){ |
5456
|
|
|
|
|
|
|
$sense = 2; |
5457
|
|
|
|
|
|
|
$rcondv = PDL::new_from_specification('PDL', $type, $dims[0]); |
5458
|
|
|
|
|
|
|
$rconde = pdl($type, 0); |
5459
|
|
|
|
|
|
|
} |
5460
|
|
|
|
|
|
|
elsif( $opt{'rcondition'} eq 'all' ){ |
5461
|
|
|
|
|
|
|
$sense = 3; |
5462
|
|
|
|
|
|
|
$rcondv = PDL::new_from_specification('PDL', $type, $dims[0]); |
5463
|
|
|
|
|
|
|
$rconde = PDL::new_from_specification('PDL', $type, $dims[0]); |
5464
|
|
|
|
|
|
|
} |
5465
|
|
|
|
|
|
|
else{ |
5466
|
|
|
|
|
|
|
$sense = 0; |
5467
|
|
|
|
|
|
|
$rconde = pdl($type, 0); |
5468
|
|
|
|
|
|
|
$rcondv = pdl($type, 0); |
5469
|
|
|
|
|
|
|
} |
5470
|
|
|
|
|
|
|
$m->xchg(0,1)->geevx( $jobvl, $jobvr, $balanc,$sense,$wr, $wi, $vl, $vr, $ilo, $ihi, $scale, $abnrm, $rconde, $rcondv, $info); |
5471
|
|
|
|
|
|
|
if ($jobvl){ |
5472
|
|
|
|
|
|
|
($w, $vl) = cplx_eigen((bless $wr, 'PDL::Complex'), $wi, $vl, 1); |
5473
|
|
|
|
|
|
|
} |
5474
|
|
|
|
|
|
|
if ($jobvr){ |
5475
|
|
|
|
|
|
|
($w, $vr) = cplx_eigen((bless $wr, 'PDL::Complex'), $wi, $vr, 1); |
5476
|
|
|
|
|
|
|
} |
5477
|
|
|
|
|
|
|
$w = PDL::Complex::complex t(cat $wr, $wi) unless $jobvr || $jobvl; |
5478
|
|
|
|
|
|
|
} |
5479
|
|
|
|
|
|
|
|
5480
|
|
|
|
|
|
|
if ($info){ |
5481
|
|
|
|
|
|
|
laerror("meigenx: The QR algorithm failed to converge"); |
5482
|
|
|
|
|
|
|
print "Returning converged eigenvalues\n" if $_laerror; |
5483
|
|
|
|
|
|
|
} |
5484
|
|
|
|
|
|
|
|
5485
|
|
|
|
|
|
|
|
5486
|
|
|
|
|
|
|
$result{'schur'} = $m if $opt{'schur'}; |
5487
|
|
|
|
|
|
|
|
5488
|
|
|
|
|
|
|
if ($opt{'permute'}){ |
5489
|
|
|
|
|
|
|
my $balance = cat $ilo, $ihi; |
5490
|
|
|
|
|
|
|
$result{'balance'} = $balance; |
5491
|
|
|
|
|
|
|
} |
5492
|
|
|
|
|
|
|
|
5493
|
|
|
|
|
|
|
$result{'info'} = $info; |
5494
|
|
|
|
|
|
|
$result{'scale'} = $scale if $opt{'scale'}; |
5495
|
|
|
|
|
|
|
$result{'norm'} = $abnrm; |
5496
|
|
|
|
|
|
|
|
5497
|
|
|
|
|
|
|
if ( $opt{'rcondition'} eq 'vector' || $opt{'rcondition'} eq "all"){ |
5498
|
|
|
|
|
|
|
$result{'rcondv'} = $rcondv; |
5499
|
|
|
|
|
|
|
$result{'verror'} = (lamch(pdl($type,0))* $abnrm /$rcondv ) if $opt{'error'}; |
5500
|
|
|
|
|
|
|
} |
5501
|
|
|
|
|
|
|
if ( $opt{'rcondition'} eq 'value' || $opt{'rcondition'} eq "all"){ |
5502
|
|
|
|
|
|
|
$result{'rconde'} = $rconde; |
5503
|
|
|
|
|
|
|
$result{'eerror'} = (lamch(pdl($type,0))* $abnrm /$rconde ) if $opt{'error'}; |
5504
|
|
|
|
|
|
|
} |
5505
|
|
|
|
|
|
|
|
5506
|
|
|
|
|
|
|
if ($opt{'vector'} eq "left"){ |
5507
|
|
|
|
|
|
|
return ($w, $vl->xchg(-2,-1)->sever, %result); |
5508
|
|
|
|
|
|
|
} |
5509
|
|
|
|
|
|
|
elsif ($opt{'vector'} eq "right"){ |
5510
|
|
|
|
|
|
|
return ($w, $vr->xchg(-2,-1)->sever, %result); |
5511
|
|
|
|
|
|
|
} |
5512
|
|
|
|
|
|
|
elsif ($opt{'vector'} eq "all"){ |
5513
|
|
|
|
|
|
|
$w, $vl->xchg(-2,-1)->sever, $vr->xchg(-2,-1)->sever, %result; |
5514
|
|
|
|
|
|
|
} |
5515
|
|
|
|
|
|
|
else{ |
5516
|
|
|
|
|
|
|
return ($w, %result); |
5517
|
|
|
|
|
|
|
} |
5518
|
|
|
|
|
|
|
|
5519
|
|
|
|
|
|
|
} |
5520
|
|
|
|
|
|
|
|
5521
|
|
|
|
|
|
|
=head2 mgeigen |
5522
|
|
|
|
|
|
|
|
5523
|
|
|
|
|
|
|
=for ref |
5524
|
|
|
|
|
|
|
|
5525
|
|
|
|
|
|
|
Computes generalized eigenvalues and, optionally, the left and/or right generalized eigenvectors |
5526
|
|
|
|
|
|
|
for a pair of N-by-N real nonsymmetric matrices (A,B) . |
5527
|
|
|
|
|
|
|
The alpha from ratio alpha/beta is object of type PDL::Complex. |
5528
|
|
|
|
|
|
|
Supports threading. Uses L or |
5529
|
|
|
|
|
|
|
L from Lapack. |
5530
|
|
|
|
|
|
|
Works on transposed arrays. |
5531
|
|
|
|
|
|
|
|
5532
|
|
|
|
|
|
|
=for usage |
5533
|
|
|
|
|
|
|
|
5534
|
|
|
|
|
|
|
( PDL(alpha), PDL(beta), ( PDL(LV), (PDL(RV) ), PDL(info)) = mgeigen(PDL(A),PDL(B) SCALAR(left vector), SCALAR(right vector)) |
5535
|
|
|
|
|
|
|
left vector : FALSE = 0 | TRUE = 1, default = 0 |
5536
|
|
|
|
|
|
|
right vector : FALSE = 0 | TRUE = 1, default = 0 |
5537
|
|
|
|
|
|
|
|
5538
|
|
|
|
|
|
|
=for example |
5539
|
|
|
|
|
|
|
|
5540
|
|
|
|
|
|
|
my $a = random(10,10); |
5541
|
|
|
|
|
|
|
my $b = random(10,10); |
5542
|
|
|
|
|
|
|
my ( $alpha, $beta, $left_eigenvectors, $right_eigenvectors ) = mgeigen($a, $b,1, 1); |
5543
|
|
|
|
|
|
|
|
5544
|
|
|
|
|
|
|
=cut |
5545
|
|
|
|
|
|
|
|
5546
|
|
|
|
|
|
|
|
5547
|
|
|
|
|
|
|
sub mgeigen{ |
5548
|
|
|
|
|
|
|
my $m = shift; |
5549
|
|
|
|
|
|
|
$m->mgeigen(@_); |
5550
|
|
|
|
|
|
|
} |
5551
|
|
|
|
|
|
|
|
5552
|
|
|
|
|
|
|
sub PDL::mgeigen { |
5553
|
|
|
|
|
|
|
my($a, $b,$jobvl,$jobvr) = @_; |
5554
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
5555
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
5556
|
|
|
|
|
|
|
|
5557
|
|
|
|
|
|
|
|
5558
|
|
|
|
|
|
|
barf("mgeigen: Require 2 square matrices of same order") |
5559
|
|
|
|
|
|
|
unless( @adims >= 2 && $adims[0] == $adims[1] && |
5560
|
|
|
|
|
|
|
@bdims >= 2 && $bdims[0] == $bdims[1] && $adims[0] == $bdims[0]); |
5561
|
|
|
|
|
|
|
barf("mgeigen: Require matrices with equal number of dimensions") |
5562
|
|
|
|
|
|
|
if( @adims != @bdims); |
5563
|
|
|
|
|
|
|
|
5564
|
|
|
|
|
|
|
|
5565
|
|
|
|
|
|
|
my ($vl, $vr, $info, $beta, $type, $wtmp); |
5566
|
|
|
|
|
|
|
$type = $a->type; |
5567
|
|
|
|
|
|
|
|
5568
|
|
|
|
|
|
|
my ($w,$wi); |
5569
|
|
|
|
|
|
|
$b = $b->xchg(0,1); |
5570
|
|
|
|
|
|
|
$wtmp = null; |
5571
|
|
|
|
|
|
|
$wi = null; |
5572
|
|
|
|
|
|
|
$beta = null; |
5573
|
|
|
|
|
|
|
$vl = $jobvl ? PDL::zeroes $a : pdl($type,0); |
5574
|
|
|
|
|
|
|
$vr = $jobvr ? PDL::zeroes $a : pdl($type,0); |
5575
|
|
|
|
|
|
|
$info = null; |
5576
|
|
|
|
|
|
|
|
5577
|
|
|
|
|
|
|
$a->xchg(0,1)->ggev($jobvl,$jobvr, $b, $wtmp, $wi, $beta, $vl, $vr, $info); |
5578
|
|
|
|
|
|
|
|
5579
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
5580
|
|
|
|
|
|
|
my ($index,@list); |
5581
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
5582
|
|
|
|
|
|
|
@list = $index->list; |
5583
|
|
|
|
|
|
|
laerror("mgeigen: Can't compute eigenvalues/vectors for PDL(s) @list: \$info = $info"); |
5584
|
|
|
|
|
|
|
} |
5585
|
|
|
|
|
|
|
|
5586
|
|
|
|
|
|
|
|
5587
|
|
|
|
|
|
|
$w = PDL::Complex::ecplx ($wtmp, $wi); |
5588
|
|
|
|
|
|
|
if ($jobvl){ |
5589
|
|
|
|
|
|
|
(undef, $vl) = cplx_eigen((bless $wtmp, 'PDL::Complex'), $wi, $vl, 1); |
5590
|
|
|
|
|
|
|
} |
5591
|
|
|
|
|
|
|
if ($jobvr){ |
5592
|
|
|
|
|
|
|
(undef, $vr) = cplx_eigen((bless $wtmp, 'PDL::Complex'), $wi, $vr, 1); |
5593
|
|
|
|
|
|
|
} |
5594
|
|
|
|
|
|
|
|
5595
|
|
|
|
|
|
|
|
5596
|
|
|
|
|
|
|
|
5597
|
|
|
|
|
|
|
$jobvl? $jobvr? ($w, $beta, $vl->xchg(1,2)->sever, $vr->xchg(1,2)->sever, $info):($w, $beta, $vl->xchg(1,2)->sever, $info) : |
5598
|
|
|
|
|
|
|
$jobvr? ($w, $beta, $vr->xchg(1,2)->sever, $info): ($w, $beta, $info); |
5599
|
|
|
|
|
|
|
|
5600
|
|
|
|
|
|
|
} |
5601
|
|
|
|
|
|
|
|
5602
|
|
|
|
|
|
|
sub PDL::Complex::mgeigen { |
5603
|
|
|
|
|
|
|
my($a, $b,$jobvl,$jobvr) = @_; |
5604
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
5605
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
5606
|
|
|
|
|
|
|
|
5607
|
|
|
|
|
|
|
my ($vl, $vr, $info, $beta, $type, $eigens); |
5608
|
|
|
|
|
|
|
|
5609
|
|
|
|
|
|
|
$type = $a->type; |
5610
|
|
|
|
|
|
|
|
5611
|
|
|
|
|
|
|
barf("mgeigen: Require 2 square matrices of same order") |
5612
|
|
|
|
|
|
|
unless( @adims >= 3 && $adims[1] == $adims[2] && |
5613
|
|
|
|
|
|
|
@bdims >= 3 && $bdims[1] == $bdims[2] && $adims[1] == $bdims[1]); |
5614
|
|
|
|
|
|
|
barf("mgeigen: Require matrices with equal number of dimensions") |
5615
|
|
|
|
|
|
|
if( @adims != @bdims); |
5616
|
|
|
|
|
|
|
|
5617
|
|
|
|
|
|
|
|
5618
|
|
|
|
|
|
|
$b = $b->xchg(1,2); |
5619
|
|
|
|
|
|
|
$eigens = PDL::Complex->null; |
5620
|
|
|
|
|
|
|
$beta = PDL::Complex->null; |
5621
|
|
|
|
|
|
|
$vl = $jobvl ? PDL::zeroes $a : pdl($type,[0,0]); |
5622
|
|
|
|
|
|
|
$vr = $jobvr ? PDL::zeroes $a : pdl($type,[0,0]); |
5623
|
|
|
|
|
|
|
$info = null; |
5624
|
|
|
|
|
|
|
|
5625
|
|
|
|
|
|
|
$a->xchg(1,2)->cggev($jobvl,$jobvr, $b, $eigens, $beta, $vl, $vr, $info); |
5626
|
|
|
|
|
|
|
|
5627
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
5628
|
|
|
|
|
|
|
my ($index,@list); |
5629
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
5630
|
|
|
|
|
|
|
@list = $index->list; |
5631
|
|
|
|
|
|
|
laerror("mgeigen: Can't compute eigenvalues/vectors for PDL(s) @list: \$info = $info"); |
5632
|
|
|
|
|
|
|
} |
5633
|
|
|
|
|
|
|
|
5634
|
|
|
|
|
|
|
$jobvl? $jobvr? ($eigens, $beta, $vl->xchg(1,2)->sever, $vr->xchg(1,2)->sever, $info):($eigens, $beta, $vl->xchg(1,2)->sever, $info) : |
5635
|
|
|
|
|
|
|
$jobvr? ($eigens, $beta, $vr->xchg(1,2)->sever, $info): ($eigens, $beta, $info); |
5636
|
|
|
|
|
|
|
|
5637
|
|
|
|
|
|
|
} |
5638
|
|
|
|
|
|
|
|
5639
|
|
|
|
|
|
|
|
5640
|
|
|
|
|
|
|
=head2 mgeigenx |
5641
|
|
|
|
|
|
|
|
5642
|
|
|
|
|
|
|
=for ref |
5643
|
|
|
|
|
|
|
|
5644
|
|
|
|
|
|
|
Computes generalized eigenvalues, one-norms and, optionally, the left and/or right generalized |
5645
|
|
|
|
|
|
|
eigenvectors for a pair of N-by-N real nonsymmetric matrices (A,B). |
5646
|
|
|
|
|
|
|
The alpha from ratio alpha/beta is object of type PDL::Complex. |
5647
|
|
|
|
|
|
|
Uses L or |
5648
|
|
|
|
|
|
|
L from Lapack. |
5649
|
|
|
|
|
|
|
Works on transposed arrays. |
5650
|
|
|
|
|
|
|
|
5651
|
|
|
|
|
|
|
=for usage |
5652
|
|
|
|
|
|
|
|
5653
|
|
|
|
|
|
|
(PDL(alpha), PDL(beta), PDL(lv), PDL(rv), HASH(result) ) = mgeigenx(PDL(a), PDL(b), HASH(options)) |
5654
|
|
|
|
|
|
|
where options are: |
5655
|
|
|
|
|
|
|
vector: eigenvectors to compute |
5656
|
|
|
|
|
|
|
'left': computes left eigenvectors |
5657
|
|
|
|
|
|
|
'right': computes right eigenvectors |
5658
|
|
|
|
|
|
|
'all': computes left and right eigenvectors |
5659
|
|
|
|
|
|
|
0: doesn't compute (default) |
5660
|
|
|
|
|
|
|
rcondition: reciprocal condition numbers to compute (returned in HASH{'rconde'} for eigenvalues and HASH{'rcondv'} for eigenvectors) |
5661
|
|
|
|
|
|
|
'value': computes reciprocal condition numbers for eigenvalues |
5662
|
|
|
|
|
|
|
'vector': computes reciprocal condition numbers for eigenvectors |
5663
|
|
|
|
|
|
|
'all': computes reciprocal condition numbers for eigenvalues and eigenvectors |
5664
|
|
|
|
|
|
|
0: doesn't compute (default) |
5665
|
|
|
|
|
|
|
error: specifie whether or not it computes the error bounds (returned in HASH{'eerror'} and HASH{'verror'}) |
5666
|
|
|
|
|
|
|
error bound = EPS * sqrt(one-norm(a)**2 + one-norm(b)**2) / rcond(e|v) |
5667
|
|
|
|
|
|
|
(reciprocal condition numbers for eigenvalues or eigenvectors must be computed). |
5668
|
|
|
|
|
|
|
1: returns error bounds |
5669
|
|
|
|
|
|
|
0: not computed |
5670
|
|
|
|
|
|
|
scale: specifie whether or not it diagonaly scales the entry matrix |
5671
|
|
|
|
|
|
|
(scale details returned in HASH : 'lscale' and 'rscale') |
5672
|
|
|
|
|
|
|
1: scales |
5673
|
|
|
|
|
|
|
0: doesn't scale (default) |
5674
|
|
|
|
|
|
|
permute: specifie whether or not it permutes row and columns |
5675
|
|
|
|
|
|
|
(permute details returned in HASH{'balance'}) |
5676
|
|
|
|
|
|
|
1: permutes |
5677
|
|
|
|
|
|
|
0: Doesn't permute (default) |
5678
|
|
|
|
|
|
|
schur: specifie whether or not it returns the Schur forms (returned in HASH{'aschur'} and HASH{'bschur'}) |
5679
|
|
|
|
|
|
|
(right or left eigenvectors must be computed). |
5680
|
|
|
|
|
|
|
1: returns Schur forms |
5681
|
|
|
|
|
|
|
0: not returned |
5682
|
|
|
|
|
|
|
Returned values: |
5683
|
|
|
|
|
|
|
alpha, |
5684
|
|
|
|
|
|
|
beta, |
5685
|
|
|
|
|
|
|
left eigenvectors if requested, |
5686
|
|
|
|
|
|
|
right eigenvectors if requested, |
5687
|
|
|
|
|
|
|
HASH{'anorm'}, HASH{'bnorm'}: |
5688
|
|
|
|
|
|
|
One-norm of the matrix A and B |
5689
|
|
|
|
|
|
|
HASH{'info'}: |
5690
|
|
|
|
|
|
|
Info: if > 0, the QR algorithm failed to compute all the eigenvalues |
5691
|
|
|
|
|
|
|
(see syevx for further details) |
5692
|
|
|
|
|
|
|
|
5693
|
|
|
|
|
|
|
=for example |
5694
|
|
|
|
|
|
|
|
5695
|
|
|
|
|
|
|
$a = random(10,10); |
5696
|
|
|
|
|
|
|
$b = random(10,10); |
5697
|
|
|
|
|
|
|
%options = (rcondition => 'all', |
5698
|
|
|
|
|
|
|
vector => 'all', |
5699
|
|
|
|
|
|
|
error => 1, |
5700
|
|
|
|
|
|
|
scale => 1, |
5701
|
|
|
|
|
|
|
permute=>1, |
5702
|
|
|
|
|
|
|
shur => 1 |
5703
|
|
|
|
|
|
|
); |
5704
|
|
|
|
|
|
|
($alpha, $beta, $left_eigenvectors, $right_eigenvectors, %result) = mgeigenx($a, $b,%options); |
5705
|
|
|
|
|
|
|
print "Error bounds for eigenvalues:\n $eigenvalues\n are:\n". transpose($result{'eerror'}) unless $info; |
5706
|
|
|
|
|
|
|
|
5707
|
|
|
|
|
|
|
=cut |
5708
|
|
|
|
|
|
|
|
5709
|
|
|
|
|
|
|
|
5710
|
|
|
|
|
|
|
*mgeigenx = \&PDL::mgeigenx; |
5711
|
|
|
|
|
|
|
|
5712
|
|
|
|
|
|
|
sub PDL::mgeigenx { |
5713
|
|
|
|
|
|
|
my($a, $b,%opt) = @_; |
5714
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
5715
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
5716
|
|
|
|
|
|
|
my (%result, $jobvl, $jobvr, $sense, $balanc, $vr, $vl, $rconde, $rcondv, |
5717
|
|
|
|
|
|
|
$wr, $wi, $beta, $info, $ilo, $ihi, $rscale, $lscale, $abnrm, $bbnrm, $type, $eigens); |
5718
|
|
|
|
|
|
|
|
5719
|
|
|
|
|
|
|
if (@adims ==3){ |
5720
|
|
|
|
|
|
|
barf("mgeigenx: Require 2 square matrices of same order") |
5721
|
|
|
|
|
|
|
unless( @adims == 3 && $adims[1] == $adims[2] && |
5722
|
|
|
|
|
|
|
@bdims == 3 && $bdims[1] == $bdims[2] && $adims[1] == $bdims[1]); |
5723
|
|
|
|
|
|
|
|
5724
|
|
|
|
|
|
|
$a = $a->copy; |
5725
|
|
|
|
|
|
|
$b = $b->xchg(-1,-2)->copy; |
5726
|
|
|
|
|
|
|
|
5727
|
|
|
|
|
|
|
$eigens = PDL::Complex->null; |
5728
|
|
|
|
|
|
|
$beta = PDL::Complex->null; |
5729
|
|
|
|
|
|
|
|
5730
|
|
|
|
|
|
|
} |
5731
|
|
|
|
|
|
|
else{ |
5732
|
|
|
|
|
|
|
barf("mgeigenx: Require 2 square matrices of same order") |
5733
|
|
|
|
|
|
|
unless( @adims == 2 && $adims[0] == $adims[1] && |
5734
|
|
|
|
|
|
|
@bdims == 2 && $bdims[0] == $bdims[1] && $adims[0] == $bdims[0]); |
5735
|
|
|
|
|
|
|
|
5736
|
|
|
|
|
|
|
$a = $a->copy; |
5737
|
|
|
|
|
|
|
$b = $b->xchg(0,1)->copy; |
5738
|
|
|
|
|
|
|
|
5739
|
|
|
|
|
|
|
$wr = null; |
5740
|
|
|
|
|
|
|
$wi = null; |
5741
|
|
|
|
|
|
|
$beta= null; |
5742
|
|
|
|
|
|
|
|
5743
|
|
|
|
|
|
|
} |
5744
|
|
|
|
|
|
|
|
5745
|
|
|
|
|
|
|
$type = $a->type; |
5746
|
|
|
|
|
|
|
$info = null; |
5747
|
|
|
|
|
|
|
$ilo = null; |
5748
|
|
|
|
|
|
|
$ihi = null; |
5749
|
|
|
|
|
|
|
|
5750
|
|
|
|
|
|
|
$rscale = zeroes($type, $adims[-1]); |
5751
|
|
|
|
|
|
|
$lscale = zeroes($type, $adims[-1]); |
5752
|
|
|
|
|
|
|
$abnrm = null; |
5753
|
|
|
|
|
|
|
$bbnrm = null; |
5754
|
|
|
|
|
|
|
|
5755
|
|
|
|
|
|
|
if ($opt{'vector'} eq 'left' || |
5756
|
|
|
|
|
|
|
$opt{'vector'} eq 'all' || |
5757
|
|
|
|
|
|
|
$opt{'rcondition'} ){ |
5758
|
|
|
|
|
|
|
$jobvl = pdl(long,1); |
5759
|
|
|
|
|
|
|
$vl = PDL::zeroes $a; |
5760
|
|
|
|
|
|
|
} |
5761
|
|
|
|
|
|
|
else{ |
5762
|
|
|
|
|
|
|
$jobvl = pdl(long,0); |
5763
|
|
|
|
|
|
|
$vl = pdl($type,0); |
5764
|
|
|
|
|
|
|
} |
5765
|
|
|
|
|
|
|
|
5766
|
|
|
|
|
|
|
if ($opt{'vector'} eq 'right' || |
5767
|
|
|
|
|
|
|
$opt{'vector'} eq 'all' || |
5768
|
|
|
|
|
|
|
$opt{'rcondition'} ){ |
5769
|
|
|
|
|
|
|
$jobvr = pdl(long,1); |
5770
|
|
|
|
|
|
|
$vr = PDL::zeroes $a; |
5771
|
|
|
|
|
|
|
} |
5772
|
|
|
|
|
|
|
else{ |
5773
|
|
|
|
|
|
|
$jobvr = pdl(long,0); |
5774
|
|
|
|
|
|
|
$vr = pdl($type,0); |
5775
|
|
|
|
|
|
|
} |
5776
|
|
|
|
|
|
|
|
5777
|
|
|
|
|
|
|
|
5778
|
|
|
|
|
|
|
if ( $opt{'rcondition'} eq 'value'){ |
5779
|
|
|
|
|
|
|
$sense = pdl(long,1); |
5780
|
|
|
|
|
|
|
$rconde = zeroes($type, $adims[-1]); |
5781
|
|
|
|
|
|
|
$rcondv = pdl($type,0); |
5782
|
|
|
|
|
|
|
} |
5783
|
|
|
|
|
|
|
elsif( $opt{'rcondition'} eq 'vector'){ |
5784
|
|
|
|
|
|
|
$sense = pdl(long,2); |
5785
|
|
|
|
|
|
|
$rcondv = zeroes($type, $adims[-1]); |
5786
|
|
|
|
|
|
|
$rconde = pdl($type,0); |
5787
|
|
|
|
|
|
|
} |
5788
|
|
|
|
|
|
|
elsif( $opt{'rcondition'} eq 'all' ){ |
5789
|
|
|
|
|
|
|
$sense = pdl(long,3); |
5790
|
|
|
|
|
|
|
$rcondv = zeroes($type, $adims[-1]); |
5791
|
|
|
|
|
|
|
$rconde = zeroes($type, $adims[-1]); |
5792
|
|
|
|
|
|
|
} |
5793
|
|
|
|
|
|
|
else{ |
5794
|
|
|
|
|
|
|
$sense = pdl(long,0); |
5795
|
|
|
|
|
|
|
$rconde = pdl($type,0); |
5796
|
|
|
|
|
|
|
$rcondv = pdl($type,0); |
5797
|
|
|
|
|
|
|
} |
5798
|
|
|
|
|
|
|
|
5799
|
|
|
|
|
|
|
|
5800
|
|
|
|
|
|
|
$balanc = ($opt{'permute'} && $opt{'scale'} ) ? pdl(long,3) : $opt{'permute'} ? pdl(long,1) : $opt{'scale'} ? pdl(long,2) : pdl(long,0); |
5801
|
|
|
|
|
|
|
|
5802
|
|
|
|
|
|
|
|
5803
|
|
|
|
|
|
|
if (@adims == 2){ |
5804
|
|
|
|
|
|
|
$a->xchg(0,1)->ggevx($balanc, $jobvl, $jobvr, $sense, $b, $wr, $wi, $beta, $vl, $vr, $ilo, $ihi, $lscale, $rscale, |
5805
|
|
|
|
|
|
|
$abnrm, $bbnrm, $rconde, $rcondv, $info); |
5806
|
|
|
|
|
|
|
$eigens = PDL::Complex::complex t(cat $wr, $wi); |
5807
|
|
|
|
|
|
|
} |
5808
|
|
|
|
|
|
|
else{ |
5809
|
|
|
|
|
|
|
$a->xchg(1,2)->cggevx($balanc, $jobvl, $jobvr, $sense, $b, $eigens, $beta, $vl, $vr, $ilo, $ihi, $lscale, $rscale, |
5810
|
|
|
|
|
|
|
$abnrm, $bbnrm, $rconde, $rcondv, $info); |
5811
|
|
|
|
|
|
|
} |
5812
|
|
|
|
|
|
|
|
5813
|
|
|
|
|
|
|
|
5814
|
|
|
|
|
|
|
|
5815
|
|
|
|
|
|
|
|
5816
|
|
|
|
|
|
|
if ( ($info > 0) && ($info < $adims[-1])){ |
5817
|
|
|
|
|
|
|
laerror("mgeigenx: The QZ algorithm failed to converge"); |
5818
|
|
|
|
|
|
|
print ("Returning converged eigenvalues\n") if $_laerror; |
5819
|
|
|
|
|
|
|
} |
5820
|
|
|
|
|
|
|
elsif($info){ |
5821
|
|
|
|
|
|
|
laerror("mgeigenx: Error from hgeqz or tgevc"); |
5822
|
|
|
|
|
|
|
} |
5823
|
|
|
|
|
|
|
|
5824
|
|
|
|
|
|
|
|
5825
|
|
|
|
|
|
|
$result{'aschur'} = $a if $opt{'schur'}; |
5826
|
|
|
|
|
|
|
$result{'bschur'} = $b->xchg(-1,-2)->sever if $opt{'schur'}; |
5827
|
|
|
|
|
|
|
|
5828
|
|
|
|
|
|
|
if ($opt{'permute'}){ |
5829
|
|
|
|
|
|
|
my $balance = cat $ilo, $ihi; |
5830
|
|
|
|
|
|
|
$result{'balance'} = $balance; |
5831
|
|
|
|
|
|
|
} |
5832
|
|
|
|
|
|
|
|
5833
|
|
|
|
|
|
|
$result{'info'} = $info; |
5834
|
|
|
|
|
|
|
$result{'rscale'} = $rscale if $opt{'scale'}; |
5835
|
|
|
|
|
|
|
$result{'lscale'} = $lscale if $opt{'scale'}; |
5836
|
|
|
|
|
|
|
|
5837
|
|
|
|
|
|
|
$result{'anorm'} = $abnrm; |
5838
|
|
|
|
|
|
|
$result{'bnorm'} = $bbnrm; |
5839
|
|
|
|
|
|
|
|
5840
|
|
|
|
|
|
|
# Doesn't use lacpy2 =(sqrt **2 , **2) without unnecessary overflow |
5841
|
|
|
|
|
|
|
if ( $opt{'rcondition'} eq 'vector' || $opt{'rcondition'} eq "all"){ |
5842
|
|
|
|
|
|
|
$result{'rcondv'} = $rcondv; |
5843
|
|
|
|
|
|
|
if ($opt{'error'}){ |
5844
|
|
|
|
|
|
|
$abnrm = sqrt ($abnrm->pow(2) + $bbnrm->pow(2)); |
5845
|
|
|
|
|
|
|
$result{'verror'} = (lamch(pdl($type,0))* $abnrm /$rcondv ); |
5846
|
|
|
|
|
|
|
} |
5847
|
|
|
|
|
|
|
} |
5848
|
|
|
|
|
|
|
if ( $opt{'rcondition'} eq 'value' || $opt{'rcondition'} eq "all"){ |
5849
|
|
|
|
|
|
|
$result{'rconde'} = $rconde; |
5850
|
|
|
|
|
|
|
if ($opt{'error'}){ |
5851
|
|
|
|
|
|
|
$abnrm = sqrt ($abnrm->pow(2) + $bbnrm->pow(2)); |
5852
|
|
|
|
|
|
|
$result{'eerror'} = (lamch(pdl($type,0))* $abnrm /$rconde ); |
5853
|
|
|
|
|
|
|
} |
5854
|
|
|
|
|
|
|
} |
5855
|
|
|
|
|
|
|
|
5856
|
|
|
|
|
|
|
if ($opt{'vector'} eq 'left'){ |
5857
|
|
|
|
|
|
|
return ($eigens, $beta, $vl->xchg(-1,-2)->sever, %result); |
5858
|
|
|
|
|
|
|
} |
5859
|
|
|
|
|
|
|
elsif ($opt{'vector'} eq 'right'){ |
5860
|
|
|
|
|
|
|
return ($eigens, $beta, $vr->xchg(-1,-2)->sever, %result); |
5861
|
|
|
|
|
|
|
} |
5862
|
|
|
|
|
|
|
elsif ($opt{'vector'} eq 'all'){ |
5863
|
|
|
|
|
|
|
return ($eigens, $beta, $vl->xchg(-1,-2)->sever, $vr->xchg(-1,-2)->sever, %result); |
5864
|
|
|
|
|
|
|
} |
5865
|
|
|
|
|
|
|
else{ |
5866
|
|
|
|
|
|
|
return ($eigens, $beta, %result); |
5867
|
|
|
|
|
|
|
} |
5868
|
|
|
|
|
|
|
|
5869
|
|
|
|
|
|
|
} |
5870
|
|
|
|
|
|
|
|
5871
|
|
|
|
|
|
|
|
5872
|
|
|
|
|
|
|
=head2 msymeigen |
5873
|
|
|
|
|
|
|
|
5874
|
|
|
|
|
|
|
=for ref |
5875
|
|
|
|
|
|
|
|
5876
|
|
|
|
|
|
|
Computes eigenvalues and, optionally eigenvectors of a real symmetric square or |
5877
|
|
|
|
|
|
|
complex Hermitian matrix (spectral decomposition). |
5878
|
|
|
|
|
|
|
The eigenvalues are computed from lower or upper triangular matrix. |
5879
|
|
|
|
|
|
|
If only eigenvalues are requested, info is returned in array context. |
5880
|
|
|
|
|
|
|
Supports threading and works inplace if eigenvectors are requested. |
5881
|
|
|
|
|
|
|
From Lapack, uses L or L for real |
5882
|
|
|
|
|
|
|
and L or L for complex. |
5883
|
|
|
|
|
|
|
Works on transposed array(s). |
5884
|
|
|
|
|
|
|
|
5885
|
|
|
|
|
|
|
=for usage |
5886
|
|
|
|
|
|
|
|
5887
|
|
|
|
|
|
|
(PDL(values), (PDL(VECTORS)), PDL(info)) = msymeigen(PDL, SCALAR(uplo), SCALAR(vector), SCALAR(method)) |
5888
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1, default = 0 |
5889
|
|
|
|
|
|
|
vector : FALSE = 0 | TRUE = 1, default = 0 |
5890
|
|
|
|
|
|
|
method : 'syev' | 'syevd' | 'cheev' | 'cheevd', default = 'syevd'|'cheevd' |
5891
|
|
|
|
|
|
|
|
5892
|
|
|
|
|
|
|
=for example |
5893
|
|
|
|
|
|
|
|
5894
|
|
|
|
|
|
|
# Assume $a is symmetric |
5895
|
|
|
|
|
|
|
my $a = random(10,10); |
5896
|
|
|
|
|
|
|
my ( $eigenvalues, $eigenvectors ) = msymeigen($a,0,1, 'syev'); |
5897
|
|
|
|
|
|
|
|
5898
|
|
|
|
|
|
|
=cut |
5899
|
|
|
|
|
|
|
|
5900
|
|
|
|
|
|
|
sub msymeigen{ |
5901
|
|
|
|
|
|
|
my $m = shift; |
5902
|
|
|
|
|
|
|
$m->msymeigen(@_); |
5903
|
|
|
|
|
|
|
} |
5904
|
|
|
|
|
|
|
|
5905
|
|
|
|
|
|
|
sub PDL::msymeigen { |
5906
|
|
|
|
|
|
|
my($m, $upper, $jobv, $method) = @_; |
5907
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
5908
|
|
|
|
|
|
|
|
5909
|
|
|
|
|
|
|
barf("msymeigen: Require square array(s)") |
5910
|
|
|
|
|
|
|
unless( @dims >= 2 && $dims[0] == $dims[1]); |
5911
|
|
|
|
|
|
|
|
5912
|
|
|
|
|
|
|
my ($w, $v, $info); |
5913
|
|
|
|
|
|
|
$info = null; |
5914
|
|
|
|
|
|
|
$w = null; |
5915
|
|
|
|
|
|
|
$method = 'syevd' unless defined $method; |
5916
|
|
|
|
|
|
|
$m = $m->copy unless ($m->is_inplace(0) and $jobv); |
5917
|
|
|
|
|
|
|
|
5918
|
|
|
|
|
|
|
$m->xchg(0,1)->$method($jobv, $upper, $w, $info); |
5919
|
|
|
|
|
|
|
|
5920
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
5921
|
|
|
|
|
|
|
my ($index,@list); |
5922
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
5923
|
|
|
|
|
|
|
@list = $index->list; |
5924
|
|
|
|
|
|
|
laerror("msymeigen: The algorithm failed to converge for PDL(s) @list: \$info = $info"); |
5925
|
|
|
|
|
|
|
} |
5926
|
|
|
|
|
|
|
|
5927
|
|
|
|
|
|
|
$jobv ? wantarray ? ($w , $m, $info) : $w : wantarray ? ($w, $info) : $w; |
5928
|
|
|
|
|
|
|
} |
5929
|
|
|
|
|
|
|
|
5930
|
|
|
|
|
|
|
sub PDL::Complex::msymeigen { |
5931
|
|
|
|
|
|
|
my($m, $upper, $jobv, $method) = @_; |
5932
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
5933
|
|
|
|
|
|
|
|
5934
|
|
|
|
|
|
|
barf("msymeigen: Require square array(s)") |
5935
|
|
|
|
|
|
|
unless( @dims >= 3 && $dims[1] == $dims[2]); |
5936
|
|
|
|
|
|
|
|
5937
|
|
|
|
|
|
|
my ($w, $v, $info); |
5938
|
|
|
|
|
|
|
$info = null; |
5939
|
|
|
|
|
|
|
$w = null; #PDL::new_from_specification('PDL', $m->type, $dims[1]); |
5940
|
|
|
|
|
|
|
$m = $m->copy unless ($m->is_inplace(0) and $jobv); |
5941
|
|
|
|
|
|
|
|
5942
|
|
|
|
|
|
|
$method = 'cheevd' unless defined $method; |
5943
|
|
|
|
|
|
|
$m->xchg(1,2)->$method($jobv, $upper, $w, $info); |
5944
|
|
|
|
|
|
|
|
5945
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
5946
|
|
|
|
|
|
|
my ($index,@list); |
5947
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
5948
|
|
|
|
|
|
|
@list = $index->list; |
5949
|
|
|
|
|
|
|
laerror("msymeigen: The algorithm failed to converge for PDL(s) @list: \$info = $info"); |
5950
|
|
|
|
|
|
|
} |
5951
|
|
|
|
|
|
|
|
5952
|
|
|
|
|
|
|
$jobv ? wantarray ? ($w , $m, $info) : $w : wantarray ? ($w, $info) : $w; |
5953
|
|
|
|
|
|
|
} |
5954
|
|
|
|
|
|
|
|
5955
|
|
|
|
|
|
|
|
5956
|
|
|
|
|
|
|
=head2 msymeigenx |
5957
|
|
|
|
|
|
|
|
5958
|
|
|
|
|
|
|
=for ref |
5959
|
|
|
|
|
|
|
|
5960
|
|
|
|
|
|
|
Computes eigenvalues and, optionally eigenvectors of a symmetric square matrix (spectral decomposition). |
5961
|
|
|
|
|
|
|
The eigenvalues are computed from lower or upper triangular matrix and can be selected by specifying a |
5962
|
|
|
|
|
|
|
range. From Lapack, uses L or |
5963
|
|
|
|
|
|
|
L for real and L |
5964
|
|
|
|
|
|
|
or L for complex. Works on transposed arrays. |
5965
|
|
|
|
|
|
|
|
5966
|
|
|
|
|
|
|
=for usage |
5967
|
|
|
|
|
|
|
|
5968
|
|
|
|
|
|
|
(PDL(value), (PDL(vector)), PDL(n), PDL(info), (PDL(support)) ) = msymeigenx(PDL, SCALAR(uplo), SCALAR(vector), HASH(options)) |
5969
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1, default = 0 |
5970
|
|
|
|
|
|
|
vector : FALSE = 0 | TRUE = 1, default = 0 |
5971
|
|
|
|
|
|
|
where options are: |
5972
|
|
|
|
|
|
|
range_type: method for selecting eigenvalues |
5973
|
|
|
|
|
|
|
indice: range of indices |
5974
|
|
|
|
|
|
|
interval: range of values |
5975
|
|
|
|
|
|
|
0: find all eigenvalues and optionally all vectors |
5976
|
|
|
|
|
|
|
range: PDL(2), lower and upper bounds interval or smallest and largest indices |
5977
|
|
|
|
|
|
|
1<=range<=N for indice |
5978
|
|
|
|
|
|
|
abstol: specifie error tolerance for eigenvalues |
5979
|
|
|
|
|
|
|
method: specifie which method to use (see Lapack for further details) |
5980
|
|
|
|
|
|
|
'syevx' (default) |
5981
|
|
|
|
|
|
|
'syevr' |
5982
|
|
|
|
|
|
|
'cheevx' (default) |
5983
|
|
|
|
|
|
|
'cheevr' |
5984
|
|
|
|
|
|
|
Returned values: |
5985
|
|
|
|
|
|
|
eigenvalues (SCALAR CONTEXT), |
5986
|
|
|
|
|
|
|
eigenvectors if requested, |
5987
|
|
|
|
|
|
|
total number of eigenvalues found (n), |
5988
|
|
|
|
|
|
|
info |
5989
|
|
|
|
|
|
|
issupz or ifail (support) according to method used and returned info, |
5990
|
|
|
|
|
|
|
for (sy|che)evx returns support only if info != 0 |
5991
|
|
|
|
|
|
|
|
5992
|
|
|
|
|
|
|
|
5993
|
|
|
|
|
|
|
=for example |
5994
|
|
|
|
|
|
|
|
5995
|
|
|
|
|
|
|
# Assume $a is symmetric |
5996
|
|
|
|
|
|
|
my $a = random(10,10); |
5997
|
|
|
|
|
|
|
my $overflow = lamch(9); |
5998
|
|
|
|
|
|
|
my $range = cat pdl(0),$overflow; |
5999
|
|
|
|
|
|
|
my $abstol = pdl(1.e-5); |
6000
|
|
|
|
|
|
|
my %options = (range_type=>'interval', |
6001
|
|
|
|
|
|
|
range => $range, |
6002
|
|
|
|
|
|
|
abstol => $abstol, |
6003
|
|
|
|
|
|
|
method=>'syevd'); |
6004
|
|
|
|
|
|
|
my ( $eigenvalues, $eigenvectors, $n, $isuppz ) = msymeigenx($a,0,1, %options); |
6005
|
|
|
|
|
|
|
|
6006
|
|
|
|
|
|
|
=cut |
6007
|
|
|
|
|
|
|
|
6008
|
|
|
|
|
|
|
*msymeigenx = \&PDL::msymeigenx; |
6009
|
|
|
|
|
|
|
|
6010
|
|
|
|
|
|
|
sub PDL::msymeigenx { |
6011
|
|
|
|
|
|
|
my($m, $upper, $jobv, %opt) = @_; |
6012
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
6013
|
|
|
|
|
|
|
|
6014
|
|
|
|
|
|
|
barf("msymeigenx: Require a square matrix") |
6015
|
|
|
|
|
|
|
unless( ( (@dims == 2)|| (@dims == 3) )&& $dims[-1] == $dims[-2]); |
6016
|
|
|
|
|
|
|
|
6017
|
|
|
|
|
|
|
my ($w, $v, $info, $n, $support, $z, $range, $method, $type); |
6018
|
|
|
|
|
|
|
|
6019
|
|
|
|
|
|
|
$type = $m->type; |
6020
|
|
|
|
|
|
|
|
6021
|
|
|
|
|
|
|
$range = ($opt{'range_type'} eq 'interval') ? pdl(long, 1) : |
6022
|
|
|
|
|
|
|
($opt{'range_type'} eq 'indice')? pdl(long, 2) : pdl(long, 0); |
6023
|
|
|
|
|
|
|
|
6024
|
|
|
|
|
|
|
if ((ref $opt{range}) ne 'PDL'){ |
6025
|
|
|
|
|
|
|
$opt{range} = pdl($type,[0,0]); |
6026
|
|
|
|
|
|
|
$range = pdl(long, 0); |
6027
|
|
|
|
|
|
|
|
6028
|
|
|
|
|
|
|
} |
6029
|
|
|
|
|
|
|
elsif ($range == 2){ |
6030
|
|
|
|
|
|
|
barf "msymeigenx: Indices must be > 0" unless $opt{range}->(0) > 0; |
6031
|
|
|
|
|
|
|
barf "msymeigenx: Indices must be <= $dims[1]" unless $opt{range}->(1) <= $dims[1]; |
6032
|
|
|
|
|
|
|
} |
6033
|
|
|
|
|
|
|
elsif ($range == 1){ |
6034
|
|
|
|
|
|
|
barf "msymeigenx: Interval limits must be differents" unless ($opt{range}->(0) != $opt{range}->(1)); |
6035
|
|
|
|
|
|
|
} |
6036
|
|
|
|
|
|
|
$w = PDL::new_from_specification('PDL', $type, $dims[1]); |
6037
|
|
|
|
|
|
|
$n = null; |
6038
|
|
|
|
|
|
|
$info = pdl(long,0); |
6039
|
|
|
|
|
|
|
|
6040
|
|
|
|
|
|
|
if (!defined $opt{'abstol'}) |
6041
|
|
|
|
|
|
|
{ |
6042
|
|
|
|
|
|
|
my ( $unfl, $ovfl ); |
6043
|
|
|
|
|
|
|
$unfl = lamch(pdl($type,1)); |
6044
|
|
|
|
|
|
|
$ovfl = lamch(pdl($type,9)); |
6045
|
|
|
|
|
|
|
$unfl->labad($ovfl); |
6046
|
|
|
|
|
|
|
$opt{'abstol'} = $unfl + $unfl; |
6047
|
|
|
|
|
|
|
} |
6048
|
|
|
|
|
|
|
|
6049
|
|
|
|
|
|
|
$method = $opt{'method'} ? $opt{'method'} : (@dims == 3) ? 'PDL::LinearAlgebra::Complex::cheevx' : 'PDL::LinearAlgebra::Real::syevx'; |
6050
|
|
|
|
|
|
|
|
6051
|
|
|
|
|
|
|
if ( $method =~ 'evx' && $jobv){ |
6052
|
|
|
|
|
|
|
$support = zeroes(long, $dims[1]); |
6053
|
|
|
|
|
|
|
} |
6054
|
|
|
|
|
|
|
elsif ($method =~ 'evr' && $jobv){ |
6055
|
|
|
|
|
|
|
$support = zeroes(long, (2*$dims[1])); |
6056
|
|
|
|
|
|
|
} |
6057
|
|
|
|
|
|
|
|
6058
|
|
|
|
|
|
|
if (@dims == 3){ |
6059
|
|
|
|
|
|
|
$upper = $upper ? pdl(long,1) : pdl(long,0); |
6060
|
|
|
|
|
|
|
$m = $m->xchg(1,2)->copy; |
6061
|
|
|
|
|
|
|
$z = $jobv ? PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1], $dims[1]) : |
6062
|
|
|
|
|
|
|
pdl($type,[0,0]); |
6063
|
|
|
|
|
|
|
$m->$method($jobv, $range, $upper, $opt{range}->(0), $opt{range}->(1),$opt{range}->(0),$opt{range}->(1), |
6064
|
|
|
|
|
|
|
$opt{'abstol'}, $n, $w, $z , $support, $info); |
6065
|
|
|
|
|
|
|
} |
6066
|
|
|
|
|
|
|
else{ |
6067
|
|
|
|
|
|
|
$upper = $upper ? pdl(long,0) : pdl(long,1); |
6068
|
|
|
|
|
|
|
$m = $m->copy; |
6069
|
|
|
|
|
|
|
$z = $jobv ? PDL::new_from_specification('PDL', $type, $dims[1], $dims[1]) : |
6070
|
|
|
|
|
|
|
pdl($type,0); |
6071
|
|
|
|
|
|
|
$m->$method($jobv, $range, $upper, $opt{range}->(0), $opt{range}->(1),$opt{range}->(0),$opt{range}->(1), |
6072
|
|
|
|
|
|
|
$opt{'abstol'}, $n, $w, $z ,$support, $info); |
6073
|
|
|
|
|
|
|
} |
6074
|
|
|
|
|
|
|
|
6075
|
|
|
|
|
|
|
if ($info){ |
6076
|
|
|
|
|
|
|
laerror("msymeigenx: The algorithm failed to converge."); |
6077
|
|
|
|
|
|
|
print ("See support for details.\n") if $_laerror; |
6078
|
|
|
|
|
|
|
} |
6079
|
|
|
|
|
|
|
|
6080
|
|
|
|
|
|
|
|
6081
|
|
|
|
|
|
|
if ($jobv){ |
6082
|
|
|
|
|
|
|
if ($info){ |
6083
|
|
|
|
|
|
|
return ($w , $z->xchg(-2,-1)->sever, $n, $info, $support); |
6084
|
|
|
|
|
|
|
} |
6085
|
|
|
|
|
|
|
elsif ($method =~ 'evr'){ |
6086
|
|
|
|
|
|
|
return (undef,undef,$n,$info,$support) if $n == 0; |
6087
|
|
|
|
|
|
|
return (@dims == 3) ? ($w(:$n-1)->sever , $z->xchg(1,2)->(,:$n-1,)->sever, $n, $info, $support) : |
6088
|
|
|
|
|
|
|
($w(:$n-1)->sever , $z->xchg(0,1)->(:$n-1,)->sever, $n, $info, $support); |
6089
|
|
|
|
|
|
|
} |
6090
|
|
|
|
|
|
|
else{ |
6091
|
|
|
|
|
|
|
return (undef,undef,$n, $info) if $n == 0; |
6092
|
|
|
|
|
|
|
return (@dims == 3) ? ($w(:$n-1)->sever , $z->xchg(1,2)->(,:$n-1,)->sever, $n, $info) : |
6093
|
|
|
|
|
|
|
($w(:$n-1)->sever , $z->xchg(0,1)->(:$n-1,)->sever, $n, $info); |
6094
|
|
|
|
|
|
|
} |
6095
|
|
|
|
|
|
|
} |
6096
|
|
|
|
|
|
|
else{ |
6097
|
|
|
|
|
|
|
if ($info){ |
6098
|
|
|
|
|
|
|
wantarray ? ($w, $n, $info, $support) : $w; |
6099
|
|
|
|
|
|
|
} |
6100
|
|
|
|
|
|
|
elsif ($method =~ 'evr'){ |
6101
|
|
|
|
|
|
|
wantarray ? ($w(:$n-1)->sever, $n, $info, $support) : $w; |
6102
|
|
|
|
|
|
|
} |
6103
|
|
|
|
|
|
|
else{ |
6104
|
|
|
|
|
|
|
wantarray ? ($w(:$n-1)->sever, $n, $info) : $w; |
6105
|
|
|
|
|
|
|
} |
6106
|
|
|
|
|
|
|
} |
6107
|
|
|
|
|
|
|
} |
6108
|
|
|
|
|
|
|
|
6109
|
|
|
|
|
|
|
=head2 msymgeigen |
6110
|
|
|
|
|
|
|
|
6111
|
|
|
|
|
|
|
=for ref |
6112
|
|
|
|
|
|
|
|
6113
|
|
|
|
|
|
|
Computes eigenvalues and, optionally eigenvectors of a real generalized |
6114
|
|
|
|
|
|
|
symmetric-definite or Hermitian-definite eigenproblem. |
6115
|
|
|
|
|
|
|
The eigenvalues are computed from lower or upper triangular matrix |
6116
|
|
|
|
|
|
|
If only eigenvalues are requested, info is returned in array context. |
6117
|
|
|
|
|
|
|
Supports threading. From Lapack, uses L or L for real |
6118
|
|
|
|
|
|
|
or L or L for complex. |
6119
|
|
|
|
|
|
|
Works on transposed array(s). |
6120
|
|
|
|
|
|
|
|
6121
|
|
|
|
|
|
|
=for usage |
6122
|
|
|
|
|
|
|
|
6123
|
|
|
|
|
|
|
(PDL(values), (PDL(vectors)), PDL(info)) = msymgeigen(PDL(a), PDL(b),SCALAR(uplo), SCALAR(vector), SCALAR(type), SCALAR(method)) |
6124
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1, default = 0 |
6125
|
|
|
|
|
|
|
vector : FALSE = 0 | TRUE = 1, default = 0 |
6126
|
|
|
|
|
|
|
type : |
6127
|
|
|
|
|
|
|
1: A * x = (lambda) * B * x |
6128
|
|
|
|
|
|
|
2: A * B * x = (lambda) * x |
6129
|
|
|
|
|
|
|
3: B * A * x = (lambda) * x |
6130
|
|
|
|
|
|
|
default = 1 |
6131
|
|
|
|
|
|
|
method : 'sygv' | 'sygvd' for real or ,'chegv' | 'chegvd' for complex, default = 'sygvd' | 'chegvd' |
6132
|
|
|
|
|
|
|
|
6133
|
|
|
|
|
|
|
=for example |
6134
|
|
|
|
|
|
|
|
6135
|
|
|
|
|
|
|
# Assume $a is symmetric |
6136
|
|
|
|
|
|
|
my $a = random(10,10); |
6137
|
|
|
|
|
|
|
my $b = random(10,10); |
6138
|
|
|
|
|
|
|
$b = $b->crossprod($b); |
6139
|
|
|
|
|
|
|
my ( $eigenvalues, $eigenvectors ) = msymgeigen($a, $b, 0, 1, 1, 'sygv'); |
6140
|
|
|
|
|
|
|
|
6141
|
|
|
|
|
|
|
=cut |
6142
|
|
|
|
|
|
|
|
6143
|
|
|
|
|
|
|
|
6144
|
|
|
|
|
|
|
sub msymgeigen{ |
6145
|
|
|
|
|
|
|
my $a = shift; |
6146
|
|
|
|
|
|
|
$a->msymgeigen(@_); |
6147
|
|
|
|
|
|
|
} |
6148
|
|
|
|
|
|
|
|
6149
|
|
|
|
|
|
|
sub PDL::msymgeigen { |
6150
|
|
|
|
|
|
|
my($a, $b, $upper, $jobv, $type, $method) = @_; |
6151
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
6152
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
6153
|
|
|
|
|
|
|
|
6154
|
|
|
|
|
|
|
barf("msymgeigen: Require square matrices of same order") |
6155
|
|
|
|
|
|
|
unless( @adims >= 2 && @bdims >= 2 && $adims[0] == $adims[1] && |
6156
|
|
|
|
|
|
|
$bdims[0] == $bdims[1] && $adims[0] == $bdims[0]); |
6157
|
|
|
|
|
|
|
barf("msymgeigen: Require matrices with equal number of dimensions") |
6158
|
|
|
|
|
|
|
if( @adims != @bdims); |
6159
|
|
|
|
|
|
|
|
6160
|
|
|
|
|
|
|
$type = 1 unless $type; |
6161
|
|
|
|
|
|
|
my ($w, $v, $info); |
6162
|
|
|
|
|
|
|
$method = 'PDL::LinearAlgebra::Real::sygvd' unless defined $method; |
6163
|
|
|
|
|
|
|
|
6164
|
|
|
|
|
|
|
|
6165
|
|
|
|
|
|
|
$upper = 1-$upper; |
6166
|
|
|
|
|
|
|
$a = $a->copy; |
6167
|
|
|
|
|
|
|
$b = $b->copy; |
6168
|
|
|
|
|
|
|
$w = null; |
6169
|
|
|
|
|
|
|
$info = null; |
6170
|
|
|
|
|
|
|
|
6171
|
|
|
|
|
|
|
$a->$method($type, $jobv, $upper, $b, $w, $info); |
6172
|
|
|
|
|
|
|
|
6173
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
6174
|
|
|
|
|
|
|
my ($index,@list); |
6175
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
6176
|
|
|
|
|
|
|
@list = $index->list; |
6177
|
|
|
|
|
|
|
laerror("msymgeigen: Can't compute eigenvalues/vectors: matrix (PDL(s) @list) is/are not positive definite(s) or the algorithm failed to converge: \$info = $info"); |
6178
|
|
|
|
|
|
|
} |
6179
|
|
|
|
|
|
|
|
6180
|
|
|
|
|
|
|
return $jobv ? ($w , $a->xchg(0,1)->sever, $info) : wantarray ? ($w, $info) : $w; |
6181
|
|
|
|
|
|
|
} |
6182
|
|
|
|
|
|
|
|
6183
|
|
|
|
|
|
|
sub PDL::Complex::msymgeigen { |
6184
|
|
|
|
|
|
|
my($a, $b, $upper, $jobv, $type, $method) = @_; |
6185
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
6186
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
6187
|
|
|
|
|
|
|
|
6188
|
|
|
|
|
|
|
barf("msymgeigen: Require 2 square matrices of same order") |
6189
|
|
|
|
|
|
|
unless( @adims >= 3 && @bdims >= 3 && $adims[1] == $adims[2] && |
6190
|
|
|
|
|
|
|
$bdims[1] == $bdims[2] && $adims[1] == $bdims[1]); |
6191
|
|
|
|
|
|
|
barf("msymgeigen: Require matrices with equal number of dimensions") |
6192
|
|
|
|
|
|
|
if( @adims != @bdims); |
6193
|
|
|
|
|
|
|
|
6194
|
|
|
|
|
|
|
|
6195
|
|
|
|
|
|
|
$type = 1 unless $type; |
6196
|
|
|
|
|
|
|
my ($w, $v, $info); |
6197
|
|
|
|
|
|
|
$method = 'PDL::LinearAlgebra::Complex::chegvd' unless defined $method; |
6198
|
|
|
|
|
|
|
|
6199
|
|
|
|
|
|
|
|
6200
|
|
|
|
|
|
|
$a = $a->xchg(1,2)->copy; |
6201
|
|
|
|
|
|
|
$b = $b->xchg(1,2)->copy; |
6202
|
|
|
|
|
|
|
$w = null; |
6203
|
|
|
|
|
|
|
$info = null; |
6204
|
|
|
|
|
|
|
|
6205
|
|
|
|
|
|
|
# TODO bug in chegv ??? |
6206
|
|
|
|
|
|
|
$a->$method($type, $jobv, $upper, $b, $w, $info); |
6207
|
|
|
|
|
|
|
|
6208
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
6209
|
|
|
|
|
|
|
my ($index,@list); |
6210
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
6211
|
|
|
|
|
|
|
@list = $index->list; |
6212
|
|
|
|
|
|
|
laerror("msymgeigen: Can't compute eigenvalues/vectors: matrix (PDL(s) @list) is/are not positive definite(s) or the algorithm failed to converge: \$info = $info"); |
6213
|
|
|
|
|
|
|
} |
6214
|
|
|
|
|
|
|
|
6215
|
|
|
|
|
|
|
return $jobv ? ($w , $a->xchg(1,2)->sever, $info) : wantarray ? ($w, $info) : $w; |
6216
|
|
|
|
|
|
|
} |
6217
|
|
|
|
|
|
|
|
6218
|
|
|
|
|
|
|
|
6219
|
|
|
|
|
|
|
|
6220
|
|
|
|
|
|
|
=head2 msymgeigenx |
6221
|
|
|
|
|
|
|
|
6222
|
|
|
|
|
|
|
=for ref |
6223
|
|
|
|
|
|
|
|
6224
|
|
|
|
|
|
|
Computes eigenvalues and, optionally eigenvectors of a real generalized |
6225
|
|
|
|
|
|
|
symmetric-definite or Hermitian eigenproblem. |
6226
|
|
|
|
|
|
|
The eigenvalues are computed from lower or upper triangular matrix and can be selected by specifying a |
6227
|
|
|
|
|
|
|
range. Uses L or L |
6228
|
|
|
|
|
|
|
from Lapack. Works on transposed arrays. |
6229
|
|
|
|
|
|
|
|
6230
|
|
|
|
|
|
|
=for usage |
6231
|
|
|
|
|
|
|
|
6232
|
|
|
|
|
|
|
(PDL(value), (PDL(vector)), PDL(info), PDL(n), (PDL(support)) ) = msymeigenx(PDL(a), PDL(b), SCALAR(uplo), SCALAR(vector), HASH(options)) |
6233
|
|
|
|
|
|
|
uplo : UPPER = 0 | LOWER = 1, default = 0 |
6234
|
|
|
|
|
|
|
vector : FALSE = 0 | TRUE = 1, default = 0 |
6235
|
|
|
|
|
|
|
where options are: |
6236
|
|
|
|
|
|
|
type : Specifies the problem type to be solved |
6237
|
|
|
|
|
|
|
1: A * x = (lambda) * B * x |
6238
|
|
|
|
|
|
|
2: A * B * x = (lambda) * x |
6239
|
|
|
|
|
|
|
3: B * A * x = (lambda) * x |
6240
|
|
|
|
|
|
|
default = 1 |
6241
|
|
|
|
|
|
|
range_type: method for selecting eigenvalues |
6242
|
|
|
|
|
|
|
indice: range of indices |
6243
|
|
|
|
|
|
|
interval: range of values |
6244
|
|
|
|
|
|
|
0: find all eigenvalues and optionally all vectors |
6245
|
|
|
|
|
|
|
range: PDL(2), lower and upper bounds interval or smallest and largest indices |
6246
|
|
|
|
|
|
|
1<=range<=N for indice |
6247
|
|
|
|
|
|
|
abstol: specifie error tolerance for eigenvalues |
6248
|
|
|
|
|
|
|
Returned values: |
6249
|
|
|
|
|
|
|
eigenvalues (SCALAR CONTEXT), |
6250
|
|
|
|
|
|
|
eigenvectors if requested, |
6251
|
|
|
|
|
|
|
total number of eigenvalues found (n), |
6252
|
|
|
|
|
|
|
info |
6253
|
|
|
|
|
|
|
ifail according to returned info (support). |
6254
|
|
|
|
|
|
|
|
6255
|
|
|
|
|
|
|
=for example |
6256
|
|
|
|
|
|
|
|
6257
|
|
|
|
|
|
|
# Assume $a is symmetric |
6258
|
|
|
|
|
|
|
my $a = random(10,10); |
6259
|
|
|
|
|
|
|
my $b = random(10,10); |
6260
|
|
|
|
|
|
|
$b = $b->crossprod($b); |
6261
|
|
|
|
|
|
|
my $overflow = lamch(9); |
6262
|
|
|
|
|
|
|
my $range = cat pdl(0),$overflow; |
6263
|
|
|
|
|
|
|
my $abstol = pdl(1.e-5); |
6264
|
|
|
|
|
|
|
my %options = (range_type=>'interval', |
6265
|
|
|
|
|
|
|
range => $range, |
6266
|
|
|
|
|
|
|
abstol => $abstol, |
6267
|
|
|
|
|
|
|
type => 1); |
6268
|
|
|
|
|
|
|
my ( $eigenvalues, $eigenvectors, $n, $isuppz ) = msymgeigenx($a, $b, 0,1, %options); |
6269
|
|
|
|
|
|
|
|
6270
|
|
|
|
|
|
|
=cut |
6271
|
|
|
|
|
|
|
|
6272
|
|
|
|
|
|
|
*msymgeigenx = \&PDL::msymgeigenx; |
6273
|
|
|
|
|
|
|
|
6274
|
|
|
|
|
|
|
sub PDL::msymgeigenx { |
6275
|
|
|
|
|
|
|
my($a, $b, $upper, $jobv, %opt) = @_; |
6276
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
6277
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
6278
|
|
|
|
|
|
|
|
6279
|
|
|
|
|
|
|
if(@adims == 3){ |
6280
|
|
|
|
|
|
|
barf("msymgeigenx: Require 2 square matrices of same order") |
6281
|
|
|
|
|
|
|
unless( @bdims == 3 && $adims[1] == $adims[2] && |
6282
|
|
|
|
|
|
|
$bdims[1] == $bdims[2] && $adims[1] == $bdims[1]); |
6283
|
|
|
|
|
|
|
} |
6284
|
|
|
|
|
|
|
else{ |
6285
|
|
|
|
|
|
|
barf("msymgeigenx: Require 2 square matrices of same order") |
6286
|
|
|
|
|
|
|
unless( @adims == 2 && @bdims == 2 && $adims[0] == $adims[1] && |
6287
|
|
|
|
|
|
|
$bdims[0] == $bdims[1] && $adims[0] == $bdims[0]); |
6288
|
|
|
|
|
|
|
} |
6289
|
|
|
|
|
|
|
|
6290
|
|
|
|
|
|
|
my ($w, $info, $n, $support, $z, $range, $type); |
6291
|
|
|
|
|
|
|
|
6292
|
|
|
|
|
|
|
$type = $a->type; |
6293
|
|
|
|
|
|
|
|
6294
|
|
|
|
|
|
|
$range = ($opt{'range_type'} eq 'interval') ? pdl(long, 1) : |
6295
|
|
|
|
|
|
|
($opt{'range_type'} eq 'indice')? pdl(long, 2) : pdl(long, 0); |
6296
|
|
|
|
|
|
|
|
6297
|
|
|
|
|
|
|
if (UNIVERSAL::isa($opt{range},'PDL')){ |
6298
|
|
|
|
|
|
|
$opt{range} = pdl($type,[0,0]); |
6299
|
|
|
|
|
|
|
$range = pdl(long, 0); |
6300
|
|
|
|
|
|
|
|
6301
|
|
|
|
|
|
|
} |
6302
|
|
|
|
|
|
|
$opt{type} = 1 unless (defined $opt{type}); |
6303
|
|
|
|
|
|
|
$w = PDL::new_from_specification('PDL', $type, $adims[1]); |
6304
|
|
|
|
|
|
|
$n = pdl(long,0); |
6305
|
|
|
|
|
|
|
$info = pdl(long,0); |
6306
|
|
|
|
|
|
|
|
6307
|
|
|
|
|
|
|
if (!defined $opt{'abstol'}){ |
6308
|
|
|
|
|
|
|
my ( $unfl, $ovfl ); |
6309
|
|
|
|
|
|
|
$unfl = lamch(pdl($type,1)); |
6310
|
|
|
|
|
|
|
$ovfl = lamch(pdl($type,9)); |
6311
|
|
|
|
|
|
|
$unfl->labad($ovfl); |
6312
|
|
|
|
|
|
|
$opt{'abstol'} = $unfl + $unfl; |
6313
|
|
|
|
|
|
|
} |
6314
|
|
|
|
|
|
|
$support = zeroes(long, $adims[1]) if $jobv; |
6315
|
|
|
|
|
|
|
$w = PDL::new_from_specification('PDL', $type, $adims[1]); |
6316
|
|
|
|
|
|
|
$z = PDL::zeroes $a; |
6317
|
|
|
|
|
|
|
if (@adims ==3){ |
6318
|
|
|
|
|
|
|
$upper = $upper ? pdl(long,1) : pdl(long,0); |
6319
|
|
|
|
|
|
|
$a = $a->xchg(-1,-2)->copy; |
6320
|
|
|
|
|
|
|
$b = $b->xchg(-1,-2)->copy; |
6321
|
|
|
|
|
|
|
$a->chegvx($opt{type}, $jobv, $range, $upper, $b, $opt{range}->(0), $opt{range}->(1),$opt{range}->(0),$opt{range}->(1), |
6322
|
|
|
|
|
|
|
$opt{'abstol'}, $n, $w, $z ,$support, $info); |
6323
|
|
|
|
|
|
|
} |
6324
|
|
|
|
|
|
|
else{ |
6325
|
|
|
|
|
|
|
$upper = $upper ? pdl(long,0) : pdl(long,1); |
6326
|
|
|
|
|
|
|
$a = $a->copy; |
6327
|
|
|
|
|
|
|
$b = $b->copy; |
6328
|
|
|
|
|
|
|
$a->sygvx($opt{type}, $jobv, $range, $upper, $b, $opt{range}->(0), $opt{range}->(1),$opt{range}->(0),$opt{range}->(1), |
6329
|
|
|
|
|
|
|
$opt{'abstol'}, $n, $w, $z ,$support, $info); |
6330
|
|
|
|
|
|
|
} |
6331
|
|
|
|
|
|
|
if ( ($info > 0) && ($info < $adims[-1])){ |
6332
|
|
|
|
|
|
|
laerror("msymgeigenx: The algorithm failed to converge"); |
6333
|
|
|
|
|
|
|
print("see support for details\n") if $_laerror; |
6334
|
|
|
|
|
|
|
} |
6335
|
|
|
|
|
|
|
elsif($info){ |
6336
|
|
|
|
|
|
|
$info = $info - $adims[-1] - 1; |
6337
|
|
|
|
|
|
|
barf("msymgeigenx: The leading minor of order $info of B is not positive definite\n"); |
6338
|
|
|
|
|
|
|
} |
6339
|
|
|
|
|
|
|
|
6340
|
|
|
|
|
|
|
if ($jobv){ |
6341
|
|
|
|
|
|
|
if ($info){ |
6342
|
|
|
|
|
|
|
return ($w , $z->xchg(-1,-2)->sever, $n, $info, $support) ; |
6343
|
|
|
|
|
|
|
} |
6344
|
|
|
|
|
|
|
else{ |
6345
|
|
|
|
|
|
|
return ($w , $z->xchg(-1,-2)->sever, $n, $info); |
6346
|
|
|
|
|
|
|
} |
6347
|
|
|
|
|
|
|
} |
6348
|
|
|
|
|
|
|
else{ |
6349
|
|
|
|
|
|
|
if ($info){ |
6350
|
|
|
|
|
|
|
wantarray ? ($w, $n, $info, $support) : $w; |
6351
|
|
|
|
|
|
|
} |
6352
|
|
|
|
|
|
|
else{ |
6353
|
|
|
|
|
|
|
wantarray ? ($w, $n, $info) : $w; |
6354
|
|
|
|
|
|
|
} |
6355
|
|
|
|
|
|
|
} |
6356
|
|
|
|
|
|
|
} |
6357
|
|
|
|
|
|
|
|
6358
|
|
|
|
|
|
|
|
6359
|
|
|
|
|
|
|
=head2 mdsvd |
6360
|
|
|
|
|
|
|
|
6361
|
|
|
|
|
|
|
=for ref |
6362
|
|
|
|
|
|
|
|
6363
|
|
|
|
|
|
|
Computes SVD using Coppen's divide and conquer algorithm. |
6364
|
|
|
|
|
|
|
Return singular values in scalar context else left (U), |
6365
|
|
|
|
|
|
|
singular values, right (V' (hermitian for complex)) singular vectors and info. |
6366
|
|
|
|
|
|
|
Supports threading. |
6367
|
|
|
|
|
|
|
If only singulars values are requested, info is only returned in array context. |
6368
|
|
|
|
|
|
|
Uses L or L from Lapack. |
6369
|
|
|
|
|
|
|
|
6370
|
|
|
|
|
|
|
=for usage |
6371
|
|
|
|
|
|
|
|
6372
|
|
|
|
|
|
|
(PDL(U), (PDL(s), PDL(V)), PDL(info)) = mdsvd(PDL, SCALAR(job)) |
6373
|
|
|
|
|
|
|
job : 0 = computes only singular values |
6374
|
|
|
|
|
|
|
1 = computes full SVD (square U and V) |
6375
|
|
|
|
|
|
|
2 = computes SVD (singular values, right and left singular vectors) |
6376
|
|
|
|
|
|
|
default = 1 |
6377
|
|
|
|
|
|
|
|
6378
|
|
|
|
|
|
|
=for example |
6379
|
|
|
|
|
|
|
|
6380
|
|
|
|
|
|
|
my $a = random(5,10); |
6381
|
|
|
|
|
|
|
my ($u, $s, $v) = mdsvd($a); |
6382
|
|
|
|
|
|
|
|
6383
|
|
|
|
|
|
|
=cut |
6384
|
|
|
|
|
|
|
|
6385
|
|
|
|
|
|
|
|
6386
|
|
|
|
|
|
|
sub mdsvd{ |
6387
|
|
|
|
|
|
|
my $a = shift; |
6388
|
|
|
|
|
|
|
$a->mdsvd(@_); |
6389
|
|
|
|
|
|
|
} |
6390
|
|
|
|
|
|
|
|
6391
|
|
|
|
|
|
|
|
6392
|
|
|
|
|
|
|
sub PDL::mdsvd { |
6393
|
|
|
|
|
|
|
my($m, $job) = @_; |
6394
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
6395
|
|
|
|
|
|
|
|
6396
|
|
|
|
|
|
|
my ($u, $s, $v, $min, $info, $type); |
6397
|
|
|
|
|
|
|
$type = $m->type; |
6398
|
|
|
|
|
|
|
if (wantarray){ |
6399
|
|
|
|
|
|
|
$job = 1 unless defined($job); |
6400
|
|
|
|
|
|
|
} |
6401
|
|
|
|
|
|
|
else{ |
6402
|
|
|
|
|
|
|
$job = 0; |
6403
|
|
|
|
|
|
|
} |
6404
|
|
|
|
|
|
|
$min = $dims[0] > $dims[1] ? $dims[1]: $dims[0]; |
6405
|
|
|
|
|
|
|
$info = null; |
6406
|
|
|
|
|
|
|
$s = null; |
6407
|
|
|
|
|
|
|
$m = $m->copy; |
6408
|
|
|
|
|
|
|
|
6409
|
|
|
|
|
|
|
if ($job){ |
6410
|
|
|
|
|
|
|
if ($job == 2){ |
6411
|
|
|
|
|
|
|
$u = PDL::new_from_specification('PDL', $type, $min, $dims[1],@dims[2..$#dims]); |
6412
|
|
|
|
|
|
|
$v = PDL::new_from_specification('PDL', $type, $dims[0],$min,@dims[2..$#dims]); |
6413
|
|
|
|
|
|
|
} |
6414
|
|
|
|
|
|
|
else{ |
6415
|
|
|
|
|
|
|
$u = PDL::new_from_specification('PDL', $type, $dims[1],$dims[1],@dims[2..$#dims]); |
6416
|
|
|
|
|
|
|
$v = PDL::new_from_specification('PDL', $type, $dims[0],$dims[0],@dims[2..$#dims]); |
6417
|
|
|
|
|
|
|
} |
6418
|
|
|
|
|
|
|
}else{ |
6419
|
|
|
|
|
|
|
$u = PDL::new_from_specification('PDL', $type, 1,1); |
6420
|
|
|
|
|
|
|
$v = PDL::new_from_specification('PDL', $type, 1,1); |
6421
|
|
|
|
|
|
|
} |
6422
|
|
|
|
|
|
|
$m->gesdd($job, $s, $v, $u, $info); |
6423
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
6424
|
|
|
|
|
|
|
my ($index,@list); |
6425
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
6426
|
|
|
|
|
|
|
@list = $index->list; |
6427
|
|
|
|
|
|
|
laerror("mdsvd: Matrix (PDL(s) @list) is/are singular(s): \$info = $info"); |
6428
|
|
|
|
|
|
|
} |
6429
|
|
|
|
|
|
|
|
6430
|
|
|
|
|
|
|
if ($job){ |
6431
|
|
|
|
|
|
|
return ($u, $s, $v, $info); |
6432
|
|
|
|
|
|
|
}else{ return wantarray ? ($s, $info) : $s; } |
6433
|
|
|
|
|
|
|
} |
6434
|
|
|
|
|
|
|
|
6435
|
|
|
|
|
|
|
#Humm... $a= cplx random(2,4,5) |
6436
|
|
|
|
|
|
|
sub PDL::Complex::mdsvd { |
6437
|
|
|
|
|
|
|
my($m, $job) = @_; |
6438
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
6439
|
|
|
|
|
|
|
|
6440
|
|
|
|
|
|
|
my ($u, $s, $v, $min, $info, $type); |
6441
|
|
|
|
|
|
|
$type = $m->type; |
6442
|
|
|
|
|
|
|
if (wantarray){ |
6443
|
|
|
|
|
|
|
$job = 1 unless defined($job); |
6444
|
|
|
|
|
|
|
} |
6445
|
|
|
|
|
|
|
else{ |
6446
|
|
|
|
|
|
|
$job = 0; |
6447
|
|
|
|
|
|
|
} |
6448
|
|
|
|
|
|
|
$min = $dims[-2] > $dims[-1] ? $dims[-1]: $dims[-2]; |
6449
|
|
|
|
|
|
|
$info=null; |
6450
|
|
|
|
|
|
|
$s = null; |
6451
|
|
|
|
|
|
|
$m = $m->copy; |
6452
|
|
|
|
|
|
|
|
6453
|
|
|
|
|
|
|
if ($job){ |
6454
|
|
|
|
|
|
|
if ($job == 2){ |
6455
|
|
|
|
|
|
|
$u = PDL::new_from_specification('PDL::Complex', $type, 2,$min, $dims[2],@dims[3..$#dims]); |
6456
|
|
|
|
|
|
|
$v = PDL::new_from_specification('PDL::Complex', $type, 2,$dims[1],$min,@dims[3..$#dims]); |
6457
|
|
|
|
|
|
|
} |
6458
|
|
|
|
|
|
|
else{ |
6459
|
|
|
|
|
|
|
$u = PDL::new_from_specification('PDL::Complex', $type, 2,$dims[2],$dims[2],@dims[3..$#dims]); |
6460
|
|
|
|
|
|
|
$v = PDL::new_from_specification('PDL::Complex', $type, 2,$dims[1],$dims[1],@dims[3..$#dims]); |
6461
|
|
|
|
|
|
|
} |
6462
|
|
|
|
|
|
|
}else{ |
6463
|
|
|
|
|
|
|
$u = PDL::new_from_specification('PDL', $type, 2,1,1); |
6464
|
|
|
|
|
|
|
$v = PDL::new_from_specification('PDL', $type, 2,1,1); |
6465
|
|
|
|
|
|
|
} |
6466
|
|
|
|
|
|
|
$m->cgesdd($job, $s, $v, $u, $info); |
6467
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
6468
|
|
|
|
|
|
|
my ($index,@list); |
6469
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
6470
|
|
|
|
|
|
|
@list = $index->list; |
6471
|
|
|
|
|
|
|
laerror("mdsvd: Matrix (PDL(s) @list) is/are singular(s): \$info = $info"); |
6472
|
|
|
|
|
|
|
} |
6473
|
|
|
|
|
|
|
|
6474
|
|
|
|
|
|
|
if ($job){ |
6475
|
|
|
|
|
|
|
return ($u, $s, $v, $info); |
6476
|
|
|
|
|
|
|
}else{ return wantarray ? ($s, $info) : $s; } |
6477
|
|
|
|
|
|
|
} |
6478
|
|
|
|
|
|
|
|
6479
|
|
|
|
|
|
|
|
6480
|
|
|
|
|
|
|
|
6481
|
|
|
|
|
|
|
=head2 msvd |
6482
|
|
|
|
|
|
|
|
6483
|
|
|
|
|
|
|
=for ref |
6484
|
|
|
|
|
|
|
|
6485
|
|
|
|
|
|
|
Computes SVD. |
6486
|
|
|
|
|
|
|
Can compute singular values, either U or V or neither. |
6487
|
|
|
|
|
|
|
Return singulars values in scalar context else left (U), |
6488
|
|
|
|
|
|
|
singular values, right (V' (hermitian for complex) singulars vector and info. |
6489
|
|
|
|
|
|
|
Supports threading. |
6490
|
|
|
|
|
|
|
If only singulars values are requested, info is returned in array context. |
6491
|
|
|
|
|
|
|
Uses L or L from Lapack. |
6492
|
|
|
|
|
|
|
|
6493
|
|
|
|
|
|
|
=for usage |
6494
|
|
|
|
|
|
|
|
6495
|
|
|
|
|
|
|
( (PDL(U)), PDL(s), (PDL(V), PDL(info)) = msvd(PDL, SCALAR(jobu), SCALAR(jobv)) |
6496
|
|
|
|
|
|
|
jobu : 0 = Doesn't compute U |
6497
|
|
|
|
|
|
|
1 = computes full SVD (square U) |
6498
|
|
|
|
|
|
|
2 = computes right singular vectors |
6499
|
|
|
|
|
|
|
default = 1 |
6500
|
|
|
|
|
|
|
jobv : 0 = Doesn't compute V |
6501
|
|
|
|
|
|
|
1 = computes full SVD (square V) |
6502
|
|
|
|
|
|
|
2 = computes left singular vectors |
6503
|
|
|
|
|
|
|
default = 1 |
6504
|
|
|
|
|
|
|
|
6505
|
|
|
|
|
|
|
=for example |
6506
|
|
|
|
|
|
|
|
6507
|
|
|
|
|
|
|
my $a = random(10,10); |
6508
|
|
|
|
|
|
|
my ($u, $s, $v) = msvd($a); |
6509
|
|
|
|
|
|
|
|
6510
|
|
|
|
|
|
|
=cut |
6511
|
|
|
|
|
|
|
|
6512
|
|
|
|
|
|
|
sub msvd{ |
6513
|
|
|
|
|
|
|
my $a = shift; |
6514
|
|
|
|
|
|
|
$a->msvd(@_); |
6515
|
|
|
|
|
|
|
} |
6516
|
|
|
|
|
|
|
|
6517
|
|
|
|
|
|
|
|
6518
|
|
|
|
|
|
|
sub PDL::msvd { |
6519
|
|
|
|
|
|
|
my($m, $jobu, $jobv) = @_; |
6520
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
6521
|
|
|
|
|
|
|
|
6522
|
|
|
|
|
|
|
my ($u, $s, $v, $min, $info, $type); |
6523
|
|
|
|
|
|
|
$type = $m->type; |
6524
|
|
|
|
|
|
|
if (wantarray){ |
6525
|
|
|
|
|
|
|
$jobu = 1 unless defined $jobu; |
6526
|
|
|
|
|
|
|
$jobv = 1 unless defined $jobv; |
6527
|
|
|
|
|
|
|
} |
6528
|
|
|
|
|
|
|
else{ |
6529
|
|
|
|
|
|
|
$jobu = 0; |
6530
|
|
|
|
|
|
|
$jobv = 0; |
6531
|
|
|
|
|
|
|
} |
6532
|
|
|
|
|
|
|
$m = $m->copy; |
6533
|
|
|
|
|
|
|
$min = $dims[-2] > $dims[-1] ? $dims[-1]: $dims[-2]; |
6534
|
|
|
|
|
|
|
$s = null; |
6535
|
|
|
|
|
|
|
$info = null; |
6536
|
|
|
|
|
|
|
|
6537
|
|
|
|
|
|
|
if ($jobv){ |
6538
|
|
|
|
|
|
|
$v = ($jobv == 1) ? PDL::new_from_specification('PDL', $type, $dims[0],$dims[0],@dims[2..$#dims]): |
6539
|
|
|
|
|
|
|
PDL::new_from_specification('PDL', $type, $dims[0],$min,@dims[2..$#dims]); |
6540
|
|
|
|
|
|
|
}else {$v = PDL::new_from_specification('PDL', $type, 1,1);} |
6541
|
|
|
|
|
|
|
if ($jobu){ |
6542
|
|
|
|
|
|
|
$u = ($jobu == 1) ? PDL::new_from_specification('PDL', $type, $dims[1],$dims[1],@dims[2..$#dims]): |
6543
|
|
|
|
|
|
|
PDL::new_from_specification('PDL', $type, $min, $dims[1],@dims[2..$#dims]); |
6544
|
|
|
|
|
|
|
|
6545
|
|
|
|
|
|
|
}else {$u = PDL::new_from_specification('PDL', $type, 1,1);} |
6546
|
|
|
|
|
|
|
$m->gesvd($jobv, $jobu,$s, $v, $u, $info); |
6547
|
|
|
|
|
|
|
|
6548
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
6549
|
|
|
|
|
|
|
my ($index,@list); |
6550
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
6551
|
|
|
|
|
|
|
@list = $index->list; |
6552
|
|
|
|
|
|
|
laerror("msvd: Matrix (PDL(s) @list) is/are singular(s): \$info = $info"); |
6553
|
|
|
|
|
|
|
} |
6554
|
|
|
|
|
|
|
|
6555
|
|
|
|
|
|
|
if ($jobu){ |
6556
|
|
|
|
|
|
|
if ($jobv){ |
6557
|
|
|
|
|
|
|
return ($u, $s, $v, $info); |
6558
|
|
|
|
|
|
|
} |
6559
|
|
|
|
|
|
|
return ($u, $s, $info); |
6560
|
|
|
|
|
|
|
} |
6561
|
|
|
|
|
|
|
elsif($jobv){ |
6562
|
|
|
|
|
|
|
return ($s, $v, $info); |
6563
|
|
|
|
|
|
|
} |
6564
|
|
|
|
|
|
|
else{return wantarray ? ($s, $info) : $s;} |
6565
|
|
|
|
|
|
|
} |
6566
|
|
|
|
|
|
|
|
6567
|
|
|
|
|
|
|
sub PDL::Complex::msvd{ |
6568
|
|
|
|
|
|
|
my($m, $jobu, $jobv) = @_; |
6569
|
|
|
|
|
|
|
my(@dims) = $m->dims; |
6570
|
|
|
|
|
|
|
|
6571
|
|
|
|
|
|
|
my ($u, $s, $v, $min, $info, $type); |
6572
|
|
|
|
|
|
|
$type = $m->type; |
6573
|
|
|
|
|
|
|
if (wantarray){ |
6574
|
|
|
|
|
|
|
$jobu = 1 unless defined $jobu; |
6575
|
|
|
|
|
|
|
$jobv = 1 unless defined $jobv; |
6576
|
|
|
|
|
|
|
} |
6577
|
|
|
|
|
|
|
else{ |
6578
|
|
|
|
|
|
|
$jobu = 0; |
6579
|
|
|
|
|
|
|
$jobv = 0; |
6580
|
|
|
|
|
|
|
} |
6581
|
|
|
|
|
|
|
$m = $m->copy; |
6582
|
|
|
|
|
|
|
$min = $dims[-2] > $dims[-1] ? $dims[-1]: $dims[-2]; |
6583
|
|
|
|
|
|
|
$s = null; |
6584
|
|
|
|
|
|
|
$info = null; |
6585
|
|
|
|
|
|
|
|
6586
|
|
|
|
|
|
|
if ($jobv){ |
6587
|
|
|
|
|
|
|
$v = ($jobv == 1) ? PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1],$dims[1],@dims[3..$#dims]): |
6588
|
|
|
|
|
|
|
PDL::new_from_specification('PDL::Complex', $type, 2, $dims[1],$min,@dims[3..$#dims]); |
6589
|
|
|
|
|
|
|
}else {$v = PDL::new_from_specification('PDL', $type, 2,1,1);} |
6590
|
|
|
|
|
|
|
if ($jobu){ |
6591
|
|
|
|
|
|
|
$u = ($jobu == 1) ? PDL::new_from_specification('PDL::Complex', $type, 2, $dims[2],$dims[2],@dims[3..$#dims]): |
6592
|
|
|
|
|
|
|
PDL::new_from_specification('PDL::Complex', $type, 2, $min, $dims[2],@dims[3..$#dims]); |
6593
|
|
|
|
|
|
|
|
6594
|
|
|
|
|
|
|
}else {$u = PDL::new_from_specification('PDL', $type, 2,1,1);} |
6595
|
|
|
|
|
|
|
$m->cgesvd($jobv, $jobu,$s, $v, $u, $info); |
6596
|
|
|
|
|
|
|
|
6597
|
|
|
|
|
|
|
if($info->max > 0 && $_laerror) { |
6598
|
|
|
|
|
|
|
my ($index,@list); |
6599
|
|
|
|
|
|
|
$index = which($info > 0)+1; |
6600
|
|
|
|
|
|
|
@list = $index->list; |
6601
|
|
|
|
|
|
|
laerror("msvd: Matrix (PDL(s) @list) is/are singular(s): \$info = $info"); |
6602
|
|
|
|
|
|
|
} |
6603
|
|
|
|
|
|
|
|
6604
|
|
|
|
|
|
|
if ($jobu){ |
6605
|
|
|
|
|
|
|
if ($jobv){ |
6606
|
|
|
|
|
|
|
return ($u, $s, $v, $info); |
6607
|
|
|
|
|
|
|
} |
6608
|
|
|
|
|
|
|
return ($u, $s, $info); |
6609
|
|
|
|
|
|
|
} |
6610
|
|
|
|
|
|
|
elsif($jobv){ |
6611
|
|
|
|
|
|
|
return ($s, $v, $info); |
6612
|
|
|
|
|
|
|
} |
6613
|
|
|
|
|
|
|
else{return wantarray ? ($s, $info) : $s;} |
6614
|
|
|
|
|
|
|
} |
6615
|
|
|
|
|
|
|
|
6616
|
|
|
|
|
|
|
|
6617
|
|
|
|
|
|
|
=head2 mgsvd |
6618
|
|
|
|
|
|
|
|
6619
|
|
|
|
|
|
|
=for ref |
6620
|
|
|
|
|
|
|
|
6621
|
|
|
|
|
|
|
Computes generalized (or quotient) singular value decomposition. |
6622
|
|
|
|
|
|
|
If the effective rank of (A',B')' is 0 return only unitary V, U, Q. |
6623
|
|
|
|
|
|
|
For complex number, needs object of type PDL::Complex. |
6624
|
|
|
|
|
|
|
Uses L or |
6625
|
|
|
|
|
|
|
L from Lapack. Works on transposed arrays. |
6626
|
|
|
|
|
|
|
|
6627
|
|
|
|
|
|
|
=for usage |
6628
|
|
|
|
|
|
|
|
6629
|
|
|
|
|
|
|
(PDL(sa), PDL(sb), %ret) = mgsvd(PDL(a), PDL(b), %HASH(options)) |
6630
|
|
|
|
|
|
|
where options are: |
6631
|
|
|
|
|
|
|
V: whether or not computes V (boolean, returned in HASH{'V'}) |
6632
|
|
|
|
|
|
|
U: whether or not computes U (boolean, returned in HASH{'U'}) |
6633
|
|
|
|
|
|
|
Q: whether or not computes Q (boolean, returned in HASH{'Q'}) |
6634
|
|
|
|
|
|
|
D1: whether or not computes D1 (boolean, returned in HASH{'D1'}) |
6635
|
|
|
|
|
|
|
D2: whether or not computes D2 (boolean, returned in HASH{'D2'}) |
6636
|
|
|
|
|
|
|
0R: whether or not computes 0R (boolean, returned in HASH{'0R'}) |
6637
|
|
|
|
|
|
|
R: whether or not computes R (boolean, returned in HASH{'R'}) |
6638
|
|
|
|
|
|
|
X: whether or not computes X (boolean, returned in HASH{'X'}) |
6639
|
|
|
|
|
|
|
all: whether or not computes all the above. |
6640
|
|
|
|
|
|
|
Returned value: |
6641
|
|
|
|
|
|
|
sa,sb : singular value pairs of A and B (generalized singular values = sa/sb) |
6642
|
|
|
|
|
|
|
$ret{'rank'} : effective numerical rank of (A',B')' |
6643
|
|
|
|
|
|
|
$ret{'info'} : info from (c)ggsvd |
6644
|
|
|
|
|
|
|
|
6645
|
|
|
|
|
|
|
=for example |
6646
|
|
|
|
|
|
|
|
6647
|
|
|
|
|
|
|
my $a = random(5,5); |
6648
|
|
|
|
|
|
|
my $b = random(5,7); |
6649
|
|
|
|
|
|
|
my ($c, $s, %ret) = mgsvd($a, $b, X => 1); |
6650
|
|
|
|
|
|
|
|
6651
|
|
|
|
|
|
|
=cut |
6652
|
|
|
|
|
|
|
|
6653
|
|
|
|
|
|
|
sub mgsvd{ |
6654
|
|
|
|
|
|
|
my $m =shift; |
6655
|
|
|
|
|
|
|
$m->mgsvd(@_); |
6656
|
|
|
|
|
|
|
} |
6657
|
|
|
|
|
|
|
|
6658
|
|
|
|
|
|
|
sub PDL::mgsvd { |
6659
|
|
|
|
|
|
|
my($a, $b, %opt) = @_; |
6660
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
6661
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
6662
|
|
|
|
|
|
|
barf("mgsvd: Require matrices with equal number of columns") |
6663
|
|
|
|
|
|
|
unless( @adims == 2 && @bdims == 2 && $adims[0] == $bdims[0] ); |
6664
|
|
|
|
|
|
|
|
6665
|
|
|
|
|
|
|
my ($U, $V, $Q, $alpha, $beta, $k, $l, $iwork, $info, $D2, $D1, $work, %ret, $X, $jobqx, $type); |
6666
|
|
|
|
|
|
|
if ($opt{all}){ |
6667
|
|
|
|
|
|
|
$opt{'V'} = 1; |
6668
|
|
|
|
|
|
|
$opt{'U'} = 1; |
6669
|
|
|
|
|
|
|
$opt{'Q'} = 1; |
6670
|
|
|
|
|
|
|
$opt{'D1'} = 1; |
6671
|
|
|
|
|
|
|
$opt{'D2'} = 1; |
6672
|
|
|
|
|
|
|
$opt{'0R'} = 1; |
6673
|
|
|
|
|
|
|
$opt{'R'} = 1; |
6674
|
|
|
|
|
|
|
$opt{'X'} = 1; |
6675
|
|
|
|
|
|
|
} |
6676
|
|
|
|
|
|
|
$type = $a->type; |
6677
|
|
|
|
|
|
|
$jobqx = ($opt{Q} || $opt{X}) ? 1 : 0; |
6678
|
|
|
|
|
|
|
$a = $a->copy; |
6679
|
|
|
|
|
|
|
$b = $b->xchg(0,1)->copy; |
6680
|
|
|
|
|
|
|
$k = null; |
6681
|
|
|
|
|
|
|
$l = null; |
6682
|
|
|
|
|
|
|
$alpha = zeroes($type, $adims[0]); |
6683
|
|
|
|
|
|
|
$beta = zeroes($type, $adims[0]); |
6684
|
|
|
|
|
|
|
|
6685
|
|
|
|
|
|
|
$U = $opt{U} ? zeroes($type, $adims[1], $adims[1]) : zeroes($type,1,1); |
6686
|
|
|
|
|
|
|
$V = $opt{V} ? zeroes($b->type, $bdims[1], $bdims[1]) : zeroes($b->type,1,1); |
6687
|
|
|
|
|
|
|
$Q = $jobqx ? zeroes($type, $adims[0], $adims[0]) : zeroes($type,1,1); |
6688
|
|
|
|
|
|
|
$iwork = zeroes(long, $adims[0]); |
6689
|
|
|
|
|
|
|
$info = pdl(long, 0); |
6690
|
|
|
|
|
|
|
$a->xchg(0,1)->ggsvd($opt{U}, $opt{V}, $jobqx, $b, $k, $l, $alpha, $beta, $U, $V, $Q, $iwork, $info); |
6691
|
|
|
|
|
|
|
laerror("mgsvd: The Jacobi procedure fails to converge") if $info; |
6692
|
|
|
|
|
|
|
|
6693
|
|
|
|
|
|
|
$ret{rank} = $k + $l; |
6694
|
|
|
|
|
|
|
warn "mgsvd: Effective rank of 0 in mgsvd" if (!$ret{rank} and $_laerror); |
6695
|
|
|
|
|
|
|
$ret{'info'} = $info; |
6696
|
|
|
|
|
|
|
|
6697
|
|
|
|
|
|
|
if (%opt){ |
6698
|
|
|
|
|
|
|
$Q = $Q->xchg(0,1)->sever if $jobqx; |
6699
|
|
|
|
|
|
|
|
6700
|
|
|
|
|
|
|
if (($adims[1] - $k - $l) < 0 && $ret{rank}){ |
6701
|
|
|
|
|
|
|
|
6702
|
|
|
|
|
|
|
if ( $opt{'0R'} || $opt{R} || $opt{X}){ |
6703
|
|
|
|
|
|
|
$a->reshape($adims[0], ($k + $l)); |
6704
|
|
|
|
|
|
|
# Slice $a ??? => always square ?? |
6705
|
|
|
|
|
|
|
$a ( ($adims[0] - (($k+$l) - $adims[1])) : , $adims[1]:) .= |
6706
|
|
|
|
|
|
|
$b(($adims[1]-$k):($l-1),($adims[0]+$adims[1]-$k - $l):($adims[0]-1))->xchg(0,1); |
6707
|
|
|
|
|
|
|
$ret{'0R'} = $a if $opt{'0R'}; |
6708
|
|
|
|
|
|
|
} |
6709
|
|
|
|
|
|
|
|
6710
|
|
|
|
|
|
|
if ($opt{'D1'}){ |
6711
|
|
|
|
|
|
|
$D1 = zeroes($type, $adims[1], $adims[1]); |
6712
|
|
|
|
|
|
|
$D1->diagonal(0,1) .= $alpha(:($adims[1]-1)); |
6713
|
|
|
|
|
|
|
$D1 = $D1->xchg(0,1)->reshape($adims[1] , ($k+$l))->xchg(0,1)->sever; |
6714
|
|
|
|
|
|
|
$ret{'D1'} = $D1; |
6715
|
|
|
|
|
|
|
} |
6716
|
|
|
|
|
|
|
} |
6717
|
|
|
|
|
|
|
elsif ($ret{rank}){ |
6718
|
|
|
|
|
|
|
if ( $opt{'0R'} || $opt{R} || $opt{X}){ |
6719
|
|
|
|
|
|
|
$a->reshape($adims[0], ($k + $l)); |
6720
|
|
|
|
|
|
|
$ret{'0R'} = $a if $opt{'0R'}; |
6721
|
|
|
|
|
|
|
} |
6722
|
|
|
|
|
|
|
|
6723
|
|
|
|
|
|
|
if ($opt{'D1'}){ |
6724
|
|
|
|
|
|
|
$D1 = zeroes($type, ($k + $l), ($k + $l)); |
6725
|
|
|
|
|
|
|
$D1->diagonal(0,1) .= $alpha(:($k+$l-1)); |
6726
|
|
|
|
|
|
|
$D1->reshape(($k + $l), $adims[1]); |
6727
|
|
|
|
|
|
|
$ret{'D1'} = $D1; |
6728
|
|
|
|
|
|
|
} |
6729
|
|
|
|
|
|
|
} |
6730
|
|
|
|
|
|
|
|
6731
|
|
|
|
|
|
|
if ($opt{'D2'} && $ret{rank}){ |
6732
|
|
|
|
|
|
|
$work = zeroes($b->type, $l, $l); |
6733
|
|
|
|
|
|
|
$work->diagonal(0,1) .= $beta($k:($k+$l-1)); |
6734
|
|
|
|
|
|
|
$D2 = zeroes($b->type, ($k + $l), $bdims[1]); |
6735
|
|
|
|
|
|
|
$D2( $k:, :($l-1) ) .= $work; |
6736
|
|
|
|
|
|
|
$ret{'D2'} = $D2; |
6737
|
|
|
|
|
|
|
} |
6738
|
|
|
|
|
|
|
|
6739
|
|
|
|
|
|
|
if ( $ret{rank} && ($opt{X} || $opt{R}) ){ |
6740
|
|
|
|
|
|
|
$work = $a( -($k + $l):,); |
6741
|
|
|
|
|
|
|
$ret{R} = $work if $opt{R}; |
6742
|
|
|
|
|
|
|
if ($opt{X}){ |
6743
|
|
|
|
|
|
|
$X = zeroes($type, $adims[0], $adims[0]); |
6744
|
|
|
|
|
|
|
$X->diagonal(0,1) .= 1 if ($adims[0] > ($k + $l)); |
6745
|
|
|
|
|
|
|
$X ( -($k + $l): , -($k + $l): ) .= mtriinv($work); |
6746
|
|
|
|
|
|
|
$ret{X} = $Q x $X; |
6747
|
|
|
|
|
|
|
} |
6748
|
|
|
|
|
|
|
|
6749
|
|
|
|
|
|
|
} |
6750
|
|
|
|
|
|
|
|
6751
|
|
|
|
|
|
|
$ret{U} = $U->xchg(0,1)->sever if $opt{U}; |
6752
|
|
|
|
|
|
|
$ret{V} = $V->xchg(0,1)->sever if $opt{V}; |
6753
|
|
|
|
|
|
|
$ret{Q} = $Q if $opt{Q}; |
6754
|
|
|
|
|
|
|
} |
6755
|
|
|
|
|
|
|
$ret{rank} ? return ($alpha($k:($k+$l-1))->sever, $beta($k:($k+$l-1))->sever, %ret ) : (undef, undef, %ret); |
6756
|
|
|
|
|
|
|
} |
6757
|
|
|
|
|
|
|
|
6758
|
|
|
|
|
|
|
sub PDL::Complex::mgsvd { |
6759
|
|
|
|
|
|
|
my($a, $b, %opt) = @_; |
6760
|
|
|
|
|
|
|
my(@adims) = $a->dims; |
6761
|
|
|
|
|
|
|
my(@bdims) = $b->dims; |
6762
|
|
|
|
|
|
|
barf("mgsvd: Require matrices with equal number of columns") |
6763
|
|
|
|
|
|
|
unless( @adims == 3 && @bdims == 3 && $adims[1] == $bdims[1] ); |
6764
|
|
|
|
|
|
|
|
6765
|
|
|
|
|
|
|
my ($U, $V, $Q, $alpha, $beta, $k, $l, $iwork, $info, $D2, $D1, $work, %ret, $X, $jobqx, $type); |
6766
|
|
|
|
|
|
|
if ($opt{all}){ |
6767
|
|
|
|
|
|
|
$opt{'V'} = 1; |
6768
|
|
|
|
|
|
|
$opt{'U'} = 1; |
6769
|
|
|
|
|
|
|
$opt{'Q'} = 1; |
6770
|
|
|
|
|
|
|
$opt{'D1'} = 1; |
6771
|
|
|
|
|
|
|
$opt{'D2'} = 1; |
6772
|
|
|
|
|
|
|
$opt{'0R'} = 1; |
6773
|
|
|
|
|
|
|
$opt{'R'} = 1; |
6774
|
|
|
|
|
|
|
$opt{'X'} = 1; |
6775
|
|
|
|
|
|
|
} |
6776
|
|
|
|
|
|
|
$type = $a->type; |
6777
|
|
|
|
|
|
|
$jobqx = ($opt{Q} || $opt{X}) ? 1 : 0; |
6778
|
|
|
|
|
|
|
$a = $a->copy; |
6779
|
|
|
|
|
|
|
$b = $b->xchg(1,2)->copy; |
6780
|
|
|
|
|
|
|
$k = null; |
6781
|
|
|
|
|
|
|
$l = null; |
6782
|
|
|
|
|
|
|
$alpha = zeroes($type, $adims[1]); |
6783
|
|
|
|
|
|
|
$beta = zeroes($type, $adims[1]); |
6784
|
|
|
|
|
|
|
|
6785
|
|
|
|
|
|
|
$U = $opt{U} ? PDL::new_from_specification('PDL::Complex', $type, 2,$adims[2], $adims[2]) : zeroes($type,1,1); |
6786
|
|
|
|
|
|
|
$V = $opt{V} ? PDL::new_from_specification('PDL::Complex', $b->type, 2,$bdims[2], $bdims[2]) : zeroes($b->type,1,1); |
6787
|
|
|
|
|
|
|
$Q = $jobqx ? PDL::new_from_specification('PDL::Complex', $type, 2,$adims[1], $adims[1]) : zeroes($type,1,1); |
6788
|
|
|
|
|
|
|
$iwork = zeroes(long, $adims[1]); |
6789
|
|
|
|
|
|
|
$info = null; |
6790
|
|
|
|
|
|
|
$a->xchg(1,2)->cggsvd($opt{U}, $opt{V}, $jobqx, $b, $k, $l, $alpha, $beta, $U, $V, $Q, $iwork, $info); |
6791
|
|
|
|
|
|
|
$k = $k->sclr; |
6792
|
|
|
|
|
|
|
$l = $l->sclr; |
6793
|
|
|
|
|
|
|
laerror("mgsvd: The Jacobi procedure fails to converge") if $info; |
6794
|
|
|
|
|
|
|
|
6795
|
|
|
|
|
|
|
$ret{rank} = $k + $l; |
6796
|
|
|
|
|
|
|
warn "mgsvd: Effective rank of 0 in mgsvd" if (!$ret{rank} and $_laerror); |
6797
|
|
|
|
|
|
|
$ret{'info'} = $info; |
6798
|
|
|
|
|
|
|
|
6799
|
|
|
|
|
|
|
if (%opt){ |
6800
|
|
|
|
|
|
|
$Q = $Q->xchg(1,2)->sever if $jobqx; |
6801
|
|
|
|
|
|
|
|
6802
|
|
|
|
|
|
|
if (($adims[2] - $k - $l) < 0 && $ret{rank}){ |
6803
|
|
|
|
|
|
|
if ( $opt{'0R'} || $opt{R} || $opt{X}){ |
6804
|
|
|
|
|
|
|
$a->reshape(2,$adims[1], ($k + $l)); |
6805
|
|
|
|
|
|
|
# Slice $a ??? => always square ?? |
6806
|
|
|
|
|
|
|
$a (, ($adims[1] - (($k+$l) - $adims[2])) : , $adims[2]:) .= |
6807
|
|
|
|
|
|
|
$b(,($adims[2]-$k):($l-1),($adims[1]+$adims[2]-$k - $l):($adims[1]-1))->xchg(1,2); |
6808
|
|
|
|
|
|
|
$ret{'0R'} = $a if $opt{'0R'}; |
6809
|
|
|
|
|
|
|
|
6810
|
|
|
|
|
|
|
} |
6811
|
|
|
|
|
|
|
if ($opt{'D1'}){ |
6812
|
|
|
|
|
|
|
$D1 = zeroes($type, $adims[2], $adims[2]); |
6813
|
|
|
|
|
|
|
$D1->diagonal(0,1) .= $alpha(:($adims[2]-1)); |
6814
|
|
|
|
|
|
|
$D1 = $D1->xchg(0,1)->reshape($adims[2] , ($k+$l))->xchg(0,1)->sever; |
6815
|
|
|
|
|
|
|
$ret{'D1'} = $D1; |
6816
|
|
|
|
|
|
|
} |
6817
|
|
|
|
|
|
|
} |
6818
|
|
|
|
|
|
|
elsif ($ret{rank}){ |
6819
|
|
|
|
|
|
|
if ( $opt{'0R'} || $opt{R} || $opt{X}){ |
6820
|
|
|
|
|
|
|
$a->reshape(2, $adims[1], ($k + $l)); |
6821
|
|
|
|
|
|
|
$ret{'0R'} = $a if $opt{'0R'}; |
6822
|
|
|
|
|
|
|
} |
6823
|
|
|
|
|
|
|
|
6824
|
|
|
|
|
|
|
if ($opt{'D1'}){ |
6825
|
|
|
|
|
|
|
$D1 = zeroes($type, ($k + $l), ($k + $l)); |
6826
|
|
|
|
|
|
|
$D1->diagonal(0,1) .= $alpha(:($k+$l-1)); |
6827
|
|
|
|
|
|
|
$D1->reshape(($k + $l), $adims[2]); |
6828
|
|
|
|
|
|
|
$ret{'D1'} = $D1; |
6829
|
|
|
|
|
|
|
} |
6830
|
|
|
|
|
|
|
} |
6831
|
|
|
|
|
|
|
|
6832
|
|
|
|
|
|
|
if ($opt{'D2'} && $ret{rank}){ |
6833
|
|
|
|
|
|
|
$work = zeroes($b->type, $l, $l); |
6834
|
|
|
|
|
|
|
$work->diagonal(0,1) .= $beta($k:($k+$l-1)); |
6835
|
|
|
|
|
|
|
$D2 = zeroes($b->type, ($k + $l), $bdims[2]); |
6836
|
|
|
|
|
|
|
$D2( $k:, :($l-1) ) .= $work; |
6837
|
|
|
|
|
|
|
$ret{'D2'} = $D2; |
6838
|
|
|
|
|
|
|
} |
6839
|
|
|
|
|
|
|
|
6840
|
|
|
|
|
|
|
if ( $ret{rank} && ($opt{X} || $opt{R}) ){ |
6841
|
|
|
|
|
|
|
$work = $a( , -($k + $l):,); |
6842
|
|
|
|
|
|
|
$ret{R} = $work if $opt{R}; |
6843
|
|
|
|
|
|
|
if ($opt{X}){ |
6844
|
|
|
|
|
|
|
# $X = #zeroes($type, 2, $adims[1], $adims[1]); |
6845
|
|
|
|
|
|
|
$X = PDL::new_from_specification('PDL::Complex', $type, 2, $adims[1], $adims[1]); |
6846
|
|
|
|
|
|
|
$X .= 0; |
6847
|
|
|
|
|
|
|
$X->diagonal(1,2)->(0,) .= 1 if ($adims[1] > ($k + $l)); |
6848
|
|
|
|
|
|
|
$X ( ,-($k + $l): , -($k + $l): ) .= mtriinv($work); |
6849
|
|
|
|
|
|
|
$ret{X} = $Q x $X; |
6850
|
|
|
|
|
|
|
} |
6851
|
|
|
|
|
|
|
|
6852
|
|
|
|
|
|
|
} |
6853
|
|
|
|
|
|
|
|
6854
|
|
|
|
|
|
|
$ret{U} = $U->xchg(1,2)->sever if $opt{U}; |
6855
|
|
|
|
|
|
|
$ret{V} = $V->xchg(1,2)->sever if $opt{V}; |
6856
|
|
|
|
|
|
|
$ret{Q} = $Q if $opt{Q}; |
6857
|
|
|
|
|
|
|
} |
6858
|
|
|
|
|
|
|
$ret{rank} ? return ($alpha($k:($k+$l-1))->sever, $beta($k:($k+$l-1))->sever, %ret ) : (undef, undef, %ret); |
6859
|
|
|
|
|
|
|
} |
6860
|
|
|
|
|
|
|
|
6861
|
|
|
|
|
|
|
|
6862
|
|
|
|
|
|
|
|
6863
|
|
|
|
|
|
|
#TODO |
6864
|
|
|
|
|
|
|
|
6865
|
|
|
|
|
|
|
# Others things |
6866
|
|
|
|
|
|
|
|
6867
|
|
|
|
|
|
|
# rectangular diag |
6868
|
|
|
|
|
|
|
# usage |
6869
|
|
|
|
|
|
|
# is_inplace and function which modify entry matrix |
6870
|
|
|
|
|
|
|
# avoid xchg |
6871
|
|
|
|
|
|
|
# threading support |
6872
|
|
|
|
|
|
|
# automatically create PDL |
6873
|
|
|
|
|
|
|
# inplace operation and memory |
6874
|
|
|
|
|
|
|
#d check s after he/she/it and matrix(s) |
6875
|
|
|
|
|
|
|
# PDL type, verify float/double |
6876
|
|
|
|
|
|
|
# eig_det qr_det |
6877
|
|
|
|
|
|
|
# (g)schur(x): |
6878
|
|
|
|
|
|
|
# if conjugate pair |
6879
|
|
|
|
|
|
|
# non generalized pb: $seldim ?? (cf: generalized) |
6880
|
|
|
|
|
|
|
# return conjugate pair if only selected? |
6881
|
|
|
|
|
|
|
# port to PDL::Matrix |
6882
|
|
|
|
|
|
|
|
6883
|
|
|
|
|
|
|
=head1 AUTHOR |
6884
|
|
|
|
|
|
|
|
6885
|
|
|
|
|
|
|
Copyright (C) Grégory Vanuxem 2005-2007. |
6886
|
|
|
|
|
|
|
|
6887
|
|
|
|
|
|
|
This library is free software; you can redistribute it and/or modify |
6888
|
|
|
|
|
|
|
it under the terms of the artistic license as specified in the Artistic |
6889
|
|
|
|
|
|
|
file. |
6890
|
|
|
|
|
|
|
|
6891
|
|
|
|
|
|
|
=cut |
6892
|
|
|
|
|
|
|
|
6893
|
|
|
|
|
|
|
1; |