1 /* -------------------------------------------------------------------------- *
2 * Simbody(tm): SimTKmath *
3 * -------------------------------------------------------------------------- *
4 * This is part of the SimTK biosimulation toolkit originating from *
5 * Simbios, the NIH National Center for Physics-Based Simulation of *
6 * Biological Structures at Stanford, funded under the NIH Roadmap for *
7 * Medical Research, grant U54 GM072970. See https://simtk.org/home/simbody. *
8 * *
9 * Portions copyright (c) 2007-12 Stanford University and the Authors. *
10 * Authors: Jack Middleton *
11 * Contributors: *
12 * *
13 * Licensed under the Apache License, Version 2.0 (the "License"); you may *
14 * not use this file except in compliance with the License. You may obtain a *
15 * copy of the License at http://www.apache.org/licenses/LICENSE-2.0. *
16 * *
17 * Unless required by applicable law or agreed to in writing, software *
18 * distributed under the License is distributed on an "AS IS" BASIS, *
19 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *
20 * See the License for the specific language governing permissions and *
21 * limitations under the License. *
22 * -------------------------------------------------------------------------- */
23
24 /**@file
25 * These is a templatized, C++ callable interface to LAPACK and BLAS.
26 * Each method must be explicitly specialized for the supported precisions.
27 */
28
29
30 #include "SimTKcommon.h"
31 #include "SimTKlapack.h"
32 #include "SimTKmath.h"
33 #include "LapackInterface.h"
34 #include "WorkSpace.h"
35 #include <cstring>
36
37 #ifdef _MSC_VER
38 #pragma warning(disable:4996) // don't warn about strcat, sprintf, etc.
39 #endif
40
41 static const double EPS = .000001;
42 namespace SimTK {
43
getLWork(float * work)44 int LapackInterface::getLWork( float* work) { return( (int)work[0] ); }
getLWork(double * work)45 int LapackInterface::getLWork( double* work) { return( (int)work[0] ); }
getLWork(std::complex<float> * work)46 int LapackInterface::getLWork( std::complex<float>* work) { return( (int)work[0].real() ); }
getLWork(std::complex<double> * work)47 int LapackInterface::getLWork( std::complex<double>* work) { return( (int)work[0].real() ); }
48
gelss(int m,int n,int mn,int nrhs,T * a,int lda,T * b,int ldb,typename CNT<T>::TReal * s,typename CNT<T>::TReal rcond,int & rank,int & info)49 template <typename T> void LapackInterface::gelss( int m, int n, int mn, int nrhs,
50 T* a, int lda, T* b, int ldb, typename CNT<T>::TReal* s,
51 typename CNT<T>::TReal rcond, int& rank, int& info){ assert(false); }
52
gelss(int m,int n,int mn,int nrhs,double * a,int lda,double * b,int ldb,double * s,double rcond,int & rank,int & info)53 template <> void LapackInterface::gelss<double>( int m, int n, int mn, int nrhs,
54 double* a, int lda, double* b, int ldb, double* s,
55 double rcond, int& rank, int& info){
56
57 double wsize[1];
58 dgelss_(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, wsize, -1, info );
59
60 int lwork = (int)wsize[0];
61 TypedWorkSpace<double> work(lwork);
62
63 dgelss_(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work.data, lwork, info );
64
65 if( info < 0 ) {
66 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dgelss", info );
67 }
68 }
69
gelss(int m,int n,int mn,int nrhs,float * a,int lda,float * b,int ldb,float * s,float rcond,int & rank,int & info)70 template <> void LapackInterface::gelss<float>( int m, int n, int mn, int nrhs,
71 float* a, int lda, float* b, int ldb, float* s,
72 float rcond, int& rank, int& info){
73
74 float wsize[1];
75 sgelss_(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, wsize, -1, info );
76
77 int lwork = (int)wsize[0];
78 TypedWorkSpace<float> work(lwork);
79
80 sgelss_(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work.data, lwork, info );
81
82 if( info < 0 ) {
83 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "sgelss", info );
84 }
85 }
86
gelss(int m,int n,int mn,int nrhs,std::complex<float> * a,int lda,std::complex<float> * b,int ldb,float * s,float rcond,int & rank,int & info)87 template <> void LapackInterface::gelss<std::complex<float> >( int m, int n, int mn, int nrhs,
88 std::complex<float>* a, int lda, std::complex<float>* b, int ldb, float* s,
89 float rcond, int& rank, int& info){
90
91 std::complex<float> wsize[1];
92 TypedWorkSpace<float> rwork(5*mn);
93 cgelss_(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, wsize, -1, rwork.data, info );
94
95 int lwork = (int)wsize[0].real();
96 TypedWorkSpace<std::complex<float> > work(lwork);
97
98 cgelss_(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work.data, lwork, rwork.data, info );
99
100 if( info < 0 ) {
101 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "cgelss", info );
102 }
103 }
104
gelss(int m,int n,int mn,int nrhs,std::complex<double> * a,int lda,std::complex<double> * b,int ldb,double * s,double rcond,int & rank,int & info)105 template <> void LapackInterface::gelss<std::complex<double> >( int m, int n, int mn, int nrhs,
106 std::complex<double>* a, int lda, std::complex<double>* b, int ldb, double* s,
107 double rcond, int& rank, int& info){
108
109 TypedWorkSpace<double> rwork(5*mn);
110 std::complex<double> wsize[1];
111 zgelss_(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, wsize, -1, rwork.data, info );
112
113 int lwork = (int)wsize[0].real();
114 TypedWorkSpace<std::complex<double> > work(lwork);
115
116 zgelss_(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work.data, lwork, rwork.data, info );
117
118 if( info < 0 ) {
119 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zgelss", info );
120 }
121 }
122
123
potrs(char uplo,const int ncol,const int nrhs,const double * lu,double * b)124 template <> void LapackInterface::potrs<double>
125 ( char uplo, const int ncol, const int nrhs, const double *lu, double *b ) {
126
127 int info;
128
129 dpotrs_(uplo, ncol, nrhs, lu, ncol, b, ncol, info, 1 );
130
131 if( info < 0 ) {
132 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dpotrs", info );
133 }
134
135 return;
136 }
137
potrs(char uplo,const int ncol,const int nrhs,const float * lu,float * b)138 template <> void LapackInterface::potrs<float>
139 ( char uplo, const int ncol, const int nrhs, const float *lu, float *b ) {
140
141 int info;
142
143 spotrs_(uplo, ncol, nrhs, lu, ncol, b, ncol, info, 1 );
144
145 if( info < 0 ) {
146 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "spotrs", info );
147 }
148
149 return;
150 }
151
potrs(char uplo,const int ncol,const int nrhs,const std::complex<float> * lu,std::complex<float> * b)152 template <> void LapackInterface::potrs<std::complex<float> >
153 ( char uplo, const int ncol, const int nrhs, const std::complex<float>* lu, std::complex<float>* b ) {
154
155 int info;
156
157 cpotrs_(uplo, ncol, nrhs, lu, ncol, b, ncol, info, 1 );
158
159 if( info < 0 ) {
160 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "cpotrs", info );
161 }
162
163 return;
164 }
165
potrs(char uplo,const int ncol,const int nrhs,const std::complex<double> * lu,std::complex<double> * b)166 template <> void LapackInterface::potrs<std::complex<double> >
167 ( char uplo, const int ncol, const int nrhs, const std::complex<double>* lu, std::complex<double>* b ) {
168
169 int info;
170
171 zpotrs_(uplo, ncol, nrhs, lu, ncol, b, ncol, info, 1 );
172
173 if( info < 0 ) {
174 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zpotrs", info );
175 }
176
177 return;
178 }
sytrs(char trans,const int ncol,const int nrhs,double * lu,int * pivots,double * b)179 template <> void LapackInterface::sytrs<double>
180 // TODO fix SimTKlapack.h for const int* pivots ( char trans, const int ncol, const int nrhs, const double *lu, const int *pivots, double *b ) {
181 ( char trans, const int ncol, const int nrhs, double *lu, int *pivots, double *b ) {
182
183 int info;
184
185 dsytrs_(trans, ncol, nrhs, lu, ncol, pivots, b, ncol, info, 1 );
186
187 if( info < 0 ) {
188 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dsytrs", info );
189 }
190
191 return;
192 }
193
sytrs(char trans,const int ncol,const int nrhs,float * lu,int * pivots,float * b)194 template <> void LapackInterface::sytrs<float>
195 // TODO ( char trans, const int ncol, const int nrhs, const float *lu, const int *pivots, float *b ) {
196 ( char trans, const int ncol, const int nrhs, float *lu, int *pivots, float *b ) {
197
198 int info;
199
200 ssytrs_(trans, ncol, nrhs, lu, ncol, pivots, b, ncol, info, 1 );
201
202 if( info < 0 ) {
203 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "ssytrs", info );
204 }
205
206 return;
207 }
208
sytrs(char trans,const int ncol,const int nrhs,std::complex<float> * lu,int * pivots,std::complex<float> * b)209 template <> void LapackInterface::sytrs<std::complex<float> >
210 // TODO ( char trans, const int ncol, const int nrhs, const std::complex<float>* lu, const int *pivots, std::complex<float>* b ) {
211 ( char trans, const int ncol, const int nrhs, std::complex<float>* lu, int *pivots, std::complex<float>* b ) {
212
213 int info;
214
215 chetrs_(trans, ncol, nrhs, lu, ncol, pivots, b, ncol, info, 1 );
216
217 if( info < 0 ) {
218 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "chetrs", info );
219 }
220 return;
221 }
222
223
sytrs(char trans,const int ncol,const int nrhs,std::complex<double> * lu,int * pivots,std::complex<double> * b)224 template <> void LapackInterface::sytrs<std::complex<double> >
225 // TODO ( char trans, const int ncol, const int nrhs, const std::complex<double>* lu, const int *pivots, std::complex<double>* b ) {
226 ( char trans, const int ncol, const int nrhs, std::complex<double>* lu, int *pivots, std::complex<double>* b ) {
227
228 int info;
229
230 zhetrs_(trans, ncol, nrhs, lu, ncol, pivots, b, ncol, info, 1 );
231
232 if( info < 0 ) {
233 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zhetrs", info );
234 }
235 return;
236 }
237
getrs(char trans,const int ncol,const int nrhs,const double * lu,const int * pivots,double * b)238 template <> void LapackInterface::getrs<double>
239 ( char trans, const int ncol, const int nrhs, const double *lu, const int *pivots, double *b ) {
240
241 int info;
242
243 dgetrs_(trans, ncol, nrhs, lu, ncol, pivots, b, ncol, info, 1 );
244
245 if( info < 0 ) {
246 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dgetrs", info );
247 }
248
249 return;
250 }
251
252
getrs(char trans,const int ncol,const int nrhs,const float * lu,const int * pivots,float * b)253 template <> void LapackInterface::getrs<float>
254 ( char trans , const int ncol, const int nrhs, const float *lu, const int *pivots, float *b ) {
255
256 int info;
257
258 sgetrs_(trans, ncol, nrhs, lu, ncol, pivots, b, ncol, info, 1 );
259
260 if( info < 0 ) {
261 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "sgetrs", info );
262 }
263
264 return;
265 }
266
getrs(char trans,const int ncol,const int nrhs,const std::complex<float> * lu,const int * pivots,complex<float> * b)267 template <> void LapackInterface::getrs<complex<float> >
268 ( char trans, const int ncol, const int nrhs, const std::complex<float> *lu, const int *pivots, complex<float> *b ) {
269
270 int info;
271
272 cgetrs_(trans, ncol, nrhs, lu, ncol, pivots, b, ncol, info, 1 );
273
274 if( info < 0 ) {
275 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "cgetrs", info );
276 }
277
278 return;
279 }
getrs(char trans,const int ncol,const int nrhs,const complex<double> * lu,const int * pivots,complex<double> * b)280 template <> void LapackInterface::getrs<complex<double> >
281 ( char trans, const int ncol, const int nrhs, const complex<double> *lu, const int *pivots, complex<double> *b ) {
282
283 int info;
284
285 zgetrs_(trans, ncol, nrhs, lu, ncol, pivots, b, ncol, info, 1 );
286
287 if( info < 0 ) {
288 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zgetrs", info );
289 }
290
291 return;
292 }
293 // selected eigenvalues for symmetric matrices
294 template <class T>
syevx(char jobz,char range,char uplo,int n,T * a,int lda,typename CNT<T>::TReal vl,typename CNT<T>::TReal vu,int il,int iu,typename CNT<T>::TReal abstol,int & nFound,typename CNT<T>::TReal * values,T * vectors,int LDVectors,int * ifail,int & info)295 void LapackInterface::syevx( char jobz, char range, char uplo, int n, T* a, int lda,
296 typename CNT<T>::TReal vl, typename CNT<T>::TReal vu, int il, int iu,
297 typename CNT<T>::TReal abstol, int& nFound, typename CNT<T>::TReal* values,
298 T* vectors, int LDVectors, int* ifail, int& info ) {
299 assert(false);
300 }
syevx(char jobz,char range,char uplo,int n,float * a,int lda,float vl,float vu,int il,int iu,float abstol,int & nFound,float * values,float * vectors,int LDVectors,int * ifail,int & info)301 template <> void LapackInterface::syevx<float>( char jobz, char range,
302 char uplo, int n, float* a, int lda, float vl, float vu, int il,
303 int iu, float abstol, int& nFound, float *values, float* vectors,
304 int LDVectors, int* ifail, int& info ) {
305
306 TypedWorkSpace<int> iwork(5*n);
307 float wsize[1];
308 ssyevx_( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, nFound,
309 values, vectors, LDVectors, wsize, -1, iwork.data, ifail, info,
310 1, 1, 1);
311
312 int lwork = (int)wsize[0];
313 TypedWorkSpace<float> work(lwork);
314 ssyevx_( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, nFound,
315 values, vectors, LDVectors, work.data, lwork, iwork.data, ifail,
316 info, 1, 1, 1);
317
318 if( info < 0 ) {
319 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "ssyevx", info );
320 }
321
322
323 return;
324 }
325
syevx(char jobz,char range,char uplo,int n,double * a,int lda,double vl,double vu,int il,int iu,double abstol,int & nFound,double * values,double * vectors,int LDVectors,int * ifail,int & info)326 template <> void LapackInterface::syevx<double>( char jobz, char range,
327 char uplo, int n, double* a, int lda, double vl, double vu, int il,
328 int iu, double abstol, int& nFound, double *values, double* vectors,
329 int LDVectors, int* ifail, int& info ) {
330
331 TypedWorkSpace<int> iwork(5*n);
332 double wsize[1];
333 dsyevx_( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, nFound,
334 values, vectors, LDVectors, wsize, -1, iwork.data, ifail, info,
335 1, 1, 1);
336
337 int lwork = (int)wsize[0];
338 TypedWorkSpace<double> work(lwork);
339 dsyevx_( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, nFound,
340 values, vectors, LDVectors, work.data, lwork, iwork.data, ifail,
341 info, 1, 1, 1);
342
343 if( info < 0 ) {
344 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dsyevx", info );
345 }
346 return;
347 }
348
syevx(char jobz,char range,char uplo,int n,std::complex<double> * a,int lda,double vl,double vu,int il,int iu,double abstol,int & nFound,double * values,std::complex<double> * vectors,int LDVectors,int * ifail,int & info)349 template <> void LapackInterface::syevx<std::complex<double> >( char jobz,
350 char range, char uplo, int n, std::complex<double>* a, int lda, double vl,
351 double vu, int il, int iu, double abstol, int& nFound, double *values,
352 std::complex<double>* vectors, int LDVectors, int* ifail, int& info ) {
353
354 TypedWorkSpace<int> iwork(5*n);
355 TypedWorkSpace<double> rwork( 7*n );
356 std::complex<double> wsize[1];
357 zheevx_( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, nFound,
358 values, vectors, LDVectors, wsize, -1, rwork.data, iwork.data,
359 ifail, info, 1, 1, 1);
360
361 int lwork = (int)wsize[0].real();
362 TypedWorkSpace<std::complex<double> > work(lwork);
363 zheevx_( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, nFound,
364 values, vectors, LDVectors, work.data, lwork, rwork.data,
365 iwork.data, ifail, info, 1, 1, 1);
366
367 if( info < 0 ) {
368 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zheevx", info );
369 }
370 return;
371 }
372
syevx(char jobz,char range,char uplo,int n,std::complex<float> * a,int lda,float vl,float vu,int il,int iu,float abstol,int & nFound,float * values,std::complex<float> * vectors,int LDVectors,int * ifail,int & info)373 template <> void LapackInterface::syevx<std::complex<float> >( char jobz,
374 char range, char uplo, int n, std::complex<float>* a, int lda, float vl,
375 float vu, int il, int iu, float abstol, int& nFound, float *values,
376 std::complex<float>* vectors, int LDVectors, int* ifail, int& info ) {
377
378 TypedWorkSpace<int> iwork(5*n);
379 TypedWorkSpace<float> rwork( 7*n );
380 std::complex<float> wsize[1];
381 cheevx_( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, nFound,
382 values, vectors, LDVectors, wsize, -1, rwork.data, iwork.data, ifail,
383 info, 1, 1, 1);
384
385 int lwork = (int)wsize[0].real();
386 TypedWorkSpace<std::complex<float> > work(lwork);
387 cheevx_( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, nFound,
388 values, vectors, LDVectors, work.data, lwork, rwork.data, iwork.data,
389 ifail, info, 1, 1, 1);
390
391 if( info < 0 ) {
392 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "cheevx", info );
393 }
394 return;
395 }
396
397 // all eigenvalues for symmetric matrices eigen vectors returned in a
398 template <class T>
syev(char jobz,char uplo,int n,T * a,int lda,typename CNT<T>::TReal * eigenValues,int & info)399 void LapackInterface::syev( char jobz, char uplo, int n,
400 T* a, int lda, typename CNT<T>::TReal * eigenValues, int& info ) {
401 assert(false);
402 }
syev(char jobz,char uplo,int n,float * a,int lda,float * eigenValues,int & info)403 template <> void LapackInterface::syev<float>( char jobz, char uplo, int n,
404 float* a, int lda, float* eigenValues, int& info ) {
405
406 float wsize[1];
407 ssyev_( jobz, uplo, n, a, lda, eigenValues, wsize, -1, info, 1, 1 );
408 int lwork = (int)wsize[0];
409 TypedWorkSpace<float> work(lwork);
410 ssyev_( jobz, uplo, n, a, lda, eigenValues, work.data, lwork, info, 1, 1 );
411
412 if( info < 0 ) {
413 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "ssyev", info );
414 }
415 }
416
syev(char jobz,char uplo,int n,double * a,int lda,double * eigenValues,int & info)417 template <> void LapackInterface::syev<double>( char jobz, char uplo, int n,
418 double* a, int lda, double* eigenValues, int& info ) {
419
420 double wsize[1];
421 dsyev_( jobz, uplo, n, a, lda, eigenValues, wsize, -1, info, 1, 1 );
422 int lwork = (int)wsize[0];
423 TypedWorkSpace<double> work(lwork);
424 dsyev_( jobz, uplo, n, a, lda, eigenValues, work.data, lwork, info, 1, 1 );
425
426 if( info < 0 ) {
427 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dsyev", info );
428 }
429 }
430
syev(char jobz,char uplo,int n,std::complex<float> * a,int lda,float * eigenValues,int & info)431 template <> void LapackInterface::syev<std::complex<float> >( char jobz, char uplo, int n,
432 std::complex<float>* a, int lda, float* eigenValues, int& info ) {
433
434 std::complex<float> wsize[1];
435 int l = 3*n -2;
436 if( l < 1 ) l = 1;
437
438 TypedWorkSpace<float> rwork( l );
439
440 cheev_( jobz, uplo, n, a, lda, eigenValues, wsize, -1, rwork.data, info, 1, 1 );
441
442 int lwork = (int)wsize[0].real();
443 TypedWorkSpace<std::complex<float> > work(lwork);
444 cheev_( jobz, uplo, n, a, lda, eigenValues, work.data, lwork, rwork.data, info, 1, 1 );
445
446 if( info < 0 ) {
447 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "cheev", info );
448 }
449 }
450
syev(char jobz,char uplo,int n,std::complex<double> * a,int lda,double * eigenValues,int & info)451 template <> void LapackInterface::syev<std::complex<double> >( char jobz, char uplo, int n,
452 std::complex<double>* a, int lda, double* eigenValues, int& info ) {
453
454 std::complex<double> wsize[1];
455 int l = 3*n -2;
456 if( l < 1 ) l = 1;
457
458 TypedWorkSpace<double> rwork( l );
459
460 zheev_( jobz, uplo, n, a, lda, eigenValues, wsize, -1, rwork.data, info, 1, 1 );
461
462 if( info < 0 ) {
463 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zheev", info );
464 }
465
466 int lwork = (int)wsize[0].real();
467 TypedWorkSpace<std::complex<double> > work(lwork);
468 zheev_( jobz, uplo, n, a, lda, eigenValues, work.data, lwork, rwork.data, info, 1, 1 );
469 }
470 template <class T>
gesdd(char jobz,int m,int n,T * a,int lda,typename CNT<T>::TReal * s,T * u,int ldu,T * vt,int ldvt,int & info)471 void LapackInterface::gesdd( char jobz, int m, int n, T* a, int lda,
472 typename CNT<T>::TReal* s, T* u, int ldu, T* vt,
473 int ldvt, int& info) {
474 assert(false);
475 }
476 template <>
gesdd(char jobz,int m,int n,float * a,int lda,float * s,float * u,int ldu,float * vt,int ldvt,int & info)477 void LapackInterface::gesdd<float>( char jobz, int m, int n, float* a, int lda,
478 float* s, float* u, int ldu, float* vt,
479 int ldvt, int& info ){
480
481 int lwork;
482 int mn = (m < n ) ? m : n; // min(m,n)
483 TypedWorkSpace<float> work(1);
484 TypedWorkSpace<int> iwork(8*mn);
485
486 sgesdd_( jobz, m, n, a, lda, s, u, ldu, vt, ldvt, work.data, -1, iwork.data, info, 1);
487 lwork = (int)work.data[0];
488 work.resize(lwork);
489 sgesdd_( jobz, m, n, a, lda, s, u, ldu, vt, ldvt, work.data, lwork, iwork.data, info, 1);
490
491 if( info < 0 ) {
492 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "sgesdd", info );
493 }
494 }
495 template <>
gesdd(char jobz,int m,int n,double * a,int lda,double * s,double * u,int ldu,double * vt,int ldvt,int & info)496 void LapackInterface::gesdd<double>( char jobz, int m, int n, double* a, int lda,
497 double* s, double* u, int ldu, double* vt,
498 int ldvt, int& info ){
499
500 int lwork;
501 int mn = (m < n ) ? m : n; // min(m,n)
502 TypedWorkSpace<double> work(1);
503 TypedWorkSpace<int> iwork(8*mn);
504
505 dgesdd_( jobz, m, n, a, lda, s, u, ldu, vt, ldvt, work.data, -1, iwork.data, info, 1);
506 lwork = (int)work.data[0];
507 work.resize(lwork);
508 dgesdd_( jobz, m, n, a, lda, s, u, ldu, vt, ldvt, work.data, lwork, iwork.data, info, 1);
509
510 if( info < 0 ) {
511 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dgesdd", info );
512 }
513 }
514 // TODO REMOVE when added to SimTKlapack.
515 extern "C" {
516 extern void cgesdd_(const char& jobz, const int& m, const int& n, std::complex<float> *a, const int& lda, float *s, std::complex<float> *u, const int& ldu, std::complex<float> *vt, const int& ldvt, std::complex<float> *work, const int& lwork, float *rwork, int *iwork, int& info, int jobz_len=1 );
517 extern void zgesdd_(const char& jobz, const int& m, const int& n, std::complex<double> *a, const int& lda, double *s, std::complex<double> *u, const int& ldu, std::complex<double> *vt, const int& ldvt, std::complex<double> *work, const int& lwork, double *rwork, int *iwork, int& info, int jobz_len=1 );
518 }
519 template <>
gesdd(char jobz,int m,int n,std::complex<float> * a,int lda,float * s,std::complex<float> * u,int ldu,std::complex<float> * vt,int ldvt,int & info)520 void LapackInterface::gesdd<std::complex<float> >( char jobz, int m, int n,
521 std::complex<float>* a, int lda, float* s, std::complex<float>* u,
522 int ldu, std::complex<float>* vt, int ldvt, int& info ){
523
524 int mn = (m < n ) ? m : n; // min(m,n)
525 TypedWorkSpace<float> rwork;
526 if( jobz == 'N' ) {
527 rwork.resize(5*mn);
528 } else {
529 rwork.resize(5*mn*mn + 7*mn);
530 }
531 TypedWorkSpace<std::complex<float> > work(1);
532 TypedWorkSpace<int> iwork(8*mn);
533
534 cgesdd_( jobz, m, n, a, lda, s, u, ldu, vt, ldvt, work.data, -1, rwork.data, iwork.data, info, 1);
535 int lwork = (int)work.data[0].real();
536 work.resize(lwork);
537 cgesdd_( jobz, m, n, a, lda, s, u, ldu, vt, ldvt, work.data, lwork, rwork.data, iwork.data, info, 1);
538
539 if( info < 0 ) {
540 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "cgesdd", info );
541 }
542 return;
543 }
544
545 template <>
gesdd(char jobz,int m,int n,std::complex<double> * a,int lda,double * s,std::complex<double> * u,int ldu,std::complex<double> * vt,int ldvt,int & info)546 void LapackInterface::gesdd<std::complex<double> >( char jobz, int m, int n,
547 std::complex<double>* a, int lda, double* s, std::complex<double>* u,
548 int ldu, std::complex<double>* vt, int ldvt, int& info ){
549
550 int mn = (m < n ) ? m : n; // min(m,n)
551 TypedWorkSpace<double> rwork;
552 if( jobz == 'N' ) {
553 rwork.resize(5*mn);
554 } else {
555 rwork.resize(5*mn*mn + 7*mn);
556 }
557 TypedWorkSpace<std::complex<double> > work(1);
558 TypedWorkSpace<int> iwork(8*mn);
559
560 zgesdd_( jobz, m, n, a, lda, s, u, ldu, vt, ldvt, work.data, -1, rwork.data, iwork.data, info, 1);
561 int lwork = (int)work.data[0].real();
562 work.resize(lwork);
563 zgesdd_( jobz, m, n, a, lda, s, u, ldu, vt, ldvt, work.data, lwork, rwork.data, iwork.data, info, 1);
564
565
566 if( info < 0 ) {
567 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zgesdd", info );
568 }
569 return;
570 }
571 // eigenvlaues for nonsymmetric matrices
572 template <class T>
geev(char jobvl,char jobvr,int n,T * a,int lda,std::complex<typename CNT<T>::TReal> * values,T * vl,int ldvl,std::complex<typename CNT<T>::TReal> * vr,int ldvr,T * work,int lwork,int & info)573 void LapackInterface::geev (char jobvl, char jobvr,
574 int n, T* a, int lda, std::complex<typename CNT<T>::TReal>* values,
575 T* vl, int ldvl, std::complex<typename CNT<T>::TReal>* vr,
576 int ldvr, T* work, int lwork, int& info ) {
577 assert(false);
578 }
579
geev(char jobvl,char jobvr,int n,double * a,int lda,std::complex<double> * values,double * vl,int ldvl,std::complex<double> * rightVectors,int ldvr,double * work,int lwork,int & info)580 template <> void LapackInterface::geev<double>
581 (char jobvl, char jobvr,
582 int n, double* a, int lda, std::complex<double>* values,
583 double* vl, int ldvl, std::complex<double>* rightVectors, int ldvr, double* work,
584 int lwork, int& info )
585 {
586 TypedWorkSpace<double> wr(n);
587 TypedWorkSpace<double> wi(n);
588 TypedWorkSpace<double> vr(n*n);
589
590 // avoid valgrind uninitialized warnings
591 for(int i=0;i<n;i++) wi.data[i] = 0;
592 dgeev_( jobvl, jobvr,
593 // n, a, lda, wr.data, wi.data, vl, ldvl, vr.data, ldvr,
594 n, a, lda, wr.data, wi.data, vl, ldvl, vr.data, ldvr,
595 work, lwork, info, 1, 1);
596
597 if( info < 0 ) {
598 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dgeev", info );
599 }
600
601 for(int i=0;i<n;i++) {
602 values[i] = std::complex<double>(wr.data[i], wi.data[i] );
603 }
604
605 /*
606 ** LAPACK returns the eigen vectors as complex conjuate pairs
607 ** if the eigen value is real ( imaginary part == 0 ) then the eigen vector is real
608 ** else the vectors are returned with the real part in the jth column and the
609 ** imaginary part in the j+1 column
610 */
611 for(int j=0;j<n;j++) {
612 if( fabs(wi.data[j]) < EPS ) {
613 for(int i=0;i<n;i++) {
614 rightVectors[j*n+i] = std::complex<double>(vr.data[j*n+i], 0.0 );
615 }
616 } else {
617 for(int i=0;i<n;i++) {
618 rightVectors[j*n+i] = std::complex<double>(vr.data[j*n+i], vr.data[(j+1)*n+i]);
619 rightVectors[(j+1)*n+i] = std::complex<double>(vr.data[j*n+i], -vr.data[(j+1)*n+i]);
620 }
621 j++;
622 }
623 }
624 /*
625 for(int j=0;j<n;j++) {
626 for(int i=0;i<n;i++) printf("%f %f ", rightVectors(i,j).real(), rightVectors(i,j).imag() );
627 printf("\n");
628 }
629 */
630 }
631
geev(char jobvl,char jobvr,int n,float * a,int lda,std::complex<float> * values,float * vl,int ldvl,std::complex<float> * rightVectors,int ldvr,float * work,int lwork,int & info)632 template <> void LapackInterface::geev<float>
633 (char jobvl, char jobvr,
634 int n, float* a, int lda, std::complex<float>* values,
635 float* vl, int ldvl, std::complex<float>* rightVectors, int ldvr, float* work,
636 int lwork, int& info )
637 {
638 TypedWorkSpace<float> wr(n);
639 TypedWorkSpace<float> wi(n);
640 TypedWorkSpace<float> vr(n*n);
641
642 // avoid valgrind uninitialized warnings
643 for(int i=0;i<n;i++) wi.data[i] = 0;
644
645 sgeev_( jobvl, jobvr,
646 n, a, lda, wr.data, wi.data, vl, ldvl, vr.data, ldvr,
647 work, lwork, info,
648 1, 1);
649
650 if( info < 0 ) {
651 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "sgeev", info );
652 }
653
654 for(int i=0;i<n;i++) {
655 values[i] = std::complex<float>(wr.data[i], wi.data[i] );
656 }
657 /*
658 ** LAPACK returns the eigen vectors as complex conjuate pairs
659 ** if the eigen value is real ( imaginary part == 0 ) then the eigen vector is real
660 ** else the vectors are returned with the real part in the jth column and the
661 ** imaginary part in the j+1 column
662 */
663 for(int j=0;j<n;j++) {
664 if( fabs(wi.data[j]) < (float)EPS ) {
665 for(int i=0;i<n;i++) {
666 rightVectors[j*n+i] = std::complex<float>(vr.data[j*n+i], 0.0 );
667 //printf(" %f ",vr.data[j*n+i] );
668 }
669 //printf("\n");
670 } else {
671 for(int i=0;i<n;i++) {
672 rightVectors[j*n+i] = std::complex<float>(vr.data[j*n+i], vr.data[(j+1)*n+i]);
673 rightVectors[(j+1)*n+i] = std::complex<float>(vr.data[j*n+i], -vr.data[(j+1)*n+i]);
674 }
675 j++;
676 }
677 }
678 }
geev(char jobvl,char jobvr,int n,std::complex<float> * a,int lda,std::complex<float> * values,std::complex<float> * vl,int ldvl,std::complex<float> * rightVectors,int ldvr,std::complex<float> * work,int lwork,int & info)679 template <> void LapackInterface::geev<std::complex<float> >
680 (char jobvl, char jobvr,
681 int n, std::complex<float>* a, int lda, std::complex<float>* values,
682 std::complex<float>* vl, int ldvl, std::complex<float>* rightVectors, int ldvr, std::complex<float>* work,
683 int lwork, int& info )
684 {
685
686 TypedWorkSpace<float> Rwork(2*n);
687 cgeev_( jobvl, jobvr,
688 n, a, lda, values, vl, ldvl, rightVectors, ldvr,
689 work, lwork, Rwork.data, info,
690 1, 1);
691
692 if( info < 0 ) {
693 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "cgeev", info );
694 }
695
696 }
697
geev(char jobvl,char jobvr,int n,std::complex<double> * a,int lda,std::complex<double> * values,std::complex<double> * vl,int ldvl,std::complex<double> * rightVectors,int ldvr,std::complex<double> * work,int lwork,int & info)698 template <> void LapackInterface::geev<std::complex<double> >
699 (char jobvl, char jobvr,
700 int n, std::complex<double>* a, int lda, std::complex<double>* values,
701 std::complex<double>* vl, int ldvl, std::complex<double>* rightVectors, int ldvr, std::complex<double>* work,
702 int lwork, int& info )
703 {
704
705 TypedWorkSpace<double> Rwork(2*n);
706 zgeev_( jobvl, jobvr,
707 n, a, lda, values, vl, ldvl, rightVectors, ldvr,
708 work, lwork, Rwork.data, info,
709 1, 1);
710
711 if( info < 0 ) {
712 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zgeev", info );
713 }
714
715 }
716 template <>
getrf(const int m,const int n,double * lu,const int lda,int * pivots,int & info)717 void LapackInterface::getrf<double>( const int m, const int n, double *lu, const int lda, int *pivots, int& info ) {
718 dgetrf_(m, n, lu, lda, pivots, info );
719 return;
720 }
721 template <>
getrf(const int m,const int n,float * lu,const int lda,int * pivots,int & info)722 void LapackInterface::getrf<float>( const int m, const int n, float *lu, const int lda, int *pivots, int& info ) {
723 sgetrf_(m, n, lu, lda, pivots, info );
724 return;
725 }
726 template <>
getrf(const int m,const int n,std::complex<double> * lu,const int lda,int * pivots,int & info)727 void LapackInterface::getrf<std::complex<double> >( const int m, const int n, std::complex<double> *lu, const int lda, int *pivots, int& info ) {
728 zgetrf_(m, n, lu, lda, pivots, info );
729
730 if( info < 0 ) {
731 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zgetrf", info );
732 }
733
734 return;
735 }
736 template <>
getrf(const int m,const int n,std::complex<float> * lu,const int lda,int * pivots,int & info)737 void LapackInterface::getrf<std::complex<float> >( const int m, const int n, std::complex<float> *lu, const int lda, int *pivots, int& info ) {
738 cgetrf_(m, n, lu, lda, pivots, info );
739
740 if( info < 0 ) {
741 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "cgetrf", info );
742 }
743 return;
744 }
745
746 template <>
tzrzf(const int & m,const int & n,double * a,const int & lda,double * tau,double * work,const int & lwork,int & info)747 void LapackInterface::tzrzf<double>( const int& m, const int& n, double* a, const int& lda, double* tau, double* work, const int& lwork, int& info ) {
748 dtzrzf_(m, n, a, lda, tau, work, lwork, info );
749
750 if( info < 0 ) {
751 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dtzrzf", info );
752 }
753 return;
754 }
755
756 template <>
tzrzf(const int & m,const int & n,float * a,const int & lda,float * tau,float * work,const int & lwork,int & info)757 void LapackInterface::tzrzf<float>( const int& m, const int& n, float* a, const int& lda, float* tau, float* work, const int& lwork, int& info ) {
758 stzrzf_(m, n, a, lda, tau, work, lwork, info );
759
760 if( info < 0 ) {
761 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "stzrzf", info );
762 }
763 return;
764 }
765
766 template <>
tzrzf(const int & m,const int & n,std::complex<double> * a,const int & lda,std::complex<double> * tau,std::complex<double> * work,const int & lwork,int & info)767 void LapackInterface::tzrzf<std::complex<double> >( const int& m, const int& n, std::complex<double>* a, const int& lda, std::complex<double>* tau, std::complex<double>* work, const int& lwork, int& info ) {
768 ztzrzf_(m, n, a, lda, tau, work, lwork, info );
769 return;
770 }
771
772 template <>
tzrzf(const int & m,const int & n,std::complex<float> * a,const int & lda,std::complex<float> * tau,std::complex<float> * work,const int & lwork,int & info)773 void LapackInterface::tzrzf<std::complex<float> >( const int& m, const int& n, std::complex<float>* a, const int& lda, std::complex<float>* tau, std::complex<float>* work, const int& lwork, int& info ) {
774 ctzrzf_(m, n, a, lda, tau, work, lwork, info );
775
776 if( info < 0 ) {
777 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "ctzrzf", info );
778 }
779 return;
780 }
781
782 template <>
geqp3(const int & m,const int & n,double * a,const int & lda,int * pivots,double * tau,double * work,const int & lwork,int & info)783 void LapackInterface::geqp3<double>( const int& m, const int& n, double* a, const int& lda, int *pivots, double* tau, double* work, const int& lwork, int& info ) {
784 dgeqp3_( m, n, a, lda, pivots, tau, work, lwork, info );
785
786 if( info < 0 ) {
787 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dgeqp3", info );
788 }
789 return;
790 }
791
792 template <>
geqp3(const int & m,const int & n,float * a,const int & lda,int * pivots,float * tau,float * work,const int & lwork,int & info)793 void LapackInterface::geqp3<float>( const int& m, const int& n, float* a, const int& lda, int *pivots, float* tau, float* work, const int& lwork, int& info ) {
794 sgeqp3_( m, n, a, lda, pivots, tau, work, lwork, info );
795
796 if( info < 0 ) {
797 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "sgeqp3", info );
798 }
799 return;
800 }
801
802 template <>
geqp3(const int & m,const int & n,std::complex<float> * a,const int & lda,int * pivots,std::complex<float> * tau,std::complex<float> * work,const int & lwork,int & info)803 void LapackInterface::geqp3<std::complex<float> >( const int& m, const int& n, std::complex<float>* a, const int& lda, int *pivots, std::complex<float>* tau, std::complex<float>* work, const int& lwork, int& info ) {
804 TypedWorkSpace<float> rwork(2*n);
805 cgeqp3_( m, n, a, lda, pivots, tau, work, lwork, rwork.data, info );
806
807 if( info < 0 ) {
808 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "cgeqp3", info );
809 }
810 return;
811 }
812
813 template <>
geqp3(const int & m,const int & n,std::complex<double> * a,const int & lda,int * pivots,std::complex<double> * tau,std::complex<double> * work,const int & lwork,int & info)814 void LapackInterface::geqp3<std::complex<double> >( const int& m, const int& n, std::complex<double>* a, const int& lda, int *pivots, std::complex<double>* tau, std::complex<double>* work, const int& lwork, int& info ) {
815 TypedWorkSpace<double> rwork(2*n);
816 zgeqp3_( m, n, a, lda, pivots, tau, work, lwork, rwork.data, info );
817
818 if( info < 0 ) {
819 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zgeqp3", info );
820 }
821 return;
822 }
823
824 template <>
lascl(const char & type,const int & kl,const int & ku,const double & cfrom,const double & cto,const int & m,const int & n,double * a,const int & lda,int & info)825 void LapackInterface::lascl<double>( const char& type, const int& kl, const int& ku, const double& cfrom, const double& cto, const int& m, const int& n, double* a, const int& lda, int& info ) {
826 //TODO dlascl_( type, kl, ku, cfrom, cto, m, n, a, lda, info, 1 );
827 dlascl_( type, kl, ku, &cfrom, &cto, m, n, a, lda, info, 1 );
828
829 if( info < 0 ) {
830 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dlascl", info );
831 }
832 return;
833 }
834
835 template <>
lascl(const char & type,const int & kl,const int & ku,const float & cfrom,const float & cto,const int & m,const int & n,float * a,const int & lda,int & info)836 void LapackInterface::lascl<float>( const char& type, const int& kl, const int& ku, const float& cfrom, const float& cto, const int& m, const int& n, float* a, const int& lda, int& info ) {
837 // TODO slascl_( type, kl, ku, cfrom, cto, m, n, a, lda, info, 1 );
838 slascl_( type, kl, ku, &cfrom, &cto, m, n, a, lda, info, 1 );
839
840 if( info < 0 ) {
841 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "slascl", info );
842 }
843 return;
844 }
845
846 template <>
lascl(const char & type,const int & kl,const int & ku,const float & cfrom,const float & cto,const int & m,const int & n,std::complex<float> * a,const int & lda,int & info)847 void LapackInterface::lascl<std::complex<float> >( const char& type, const int& kl, const int& ku, const float& cfrom, const float& cto, const int& m, const int& n, std::complex<float>* a, const int& lda, int& info) {
848 // TODO clascl_( type, kl, ku, cfrom, cto, m, n, a, lda, info, 1 );
849 clascl_( type, kl, ku, &cfrom, &cto, m, n, a, lda, info, 1 );
850
851 if( info < 0 ) {
852 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "clascl", info );
853 }
854 return;
855 }
856
857 template <>
lascl(const char & type,const int & kl,const int & ku,const double & cfrom,const double & cto,const int & m,const int & n,std::complex<double> * a,const int & lda,int & info)858 void LapackInterface::lascl<std::complex<double> >( const char& type, const int& kl, const int& ku, const double& cfrom, const double& cto, const int& m, const int& n, std::complex<double>* a, const int& lda, int& info) {
859 // TODO zlascl_( type, kl, ku, cfrom, cto, m, n, a, lda, info, 1 );
860 zlascl_( type, kl, ku, &cfrom, &cto, m, n, a, lda, info, 1 );
861
862 if( info < 0 ) {
863 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zlascl", info );
864 }
865 return;
866 }
867
868
869 template <>
lange(const char & norm,const int & m,const int & n,const float * a,const int & lda)870 double LapackInterface::lange<float>( const char& norm, const int& m, const int& n, const float* a, const int& lda){
871 /*
872 TODO JACKM because g77 returns FORTRAN REAL's as doubles and gfortran returns them as floats
873 changes this once everyone has changed to new libraries and SimTKlapack.h has been updated
874 TypedWorkSpace<float> work(m);
875 return( slange_( norm, m, n, a, lda, work.data, 1 ) );
876 */
877
878 TypedWorkSpace<double> work(m);
879 TypedWorkSpace<double> da(m*n);
880 // Copy float matrix in Lapack full storage format into temporary
881 // dense double matrix.
882 for (int j=0; j<n; j++)
883 for (int i=0; i<m; i++)
884 da.data[j*m + i] = a[j*lda + i];
885 // leading dimension of da.data is m now, not lda
886 return( dlange_( norm, m, n, da.data, m, work.data, 1 ) );
887 }
888
889 template <>
lange(const char & norm,const int & m,const int & n,const double * a,const int & lda)890 double LapackInterface::lange<double>( const char& norm, const int& m, const int& n, const double* a, const int& lda ){
891 TypedWorkSpace<double> work(m);
892 return( dlange_( norm, m, n, a, lda, work.data, 1 ) );
893 }
894
895 template <>
lange(const char & norm,const int & m,const int & n,const std::complex<float> * a,const int & lda)896 double LapackInterface::lange<std::complex<float> >( const char& norm, const int& m, const int& n, const std::complex<float>* a, const int& lda ){
897 /*
898 TODO JACKM because g77 returns FORTRAN REAL's as doubles and gfortran returns them as floats
899 switch to correct LAPACK call when everyone uses SimTKlapack.h has been updated
900 TypedWorkSpace<float> work(m);
901 return( clange_( norm, m, n, a, lda, work.data, 1 ) );
902 */
903 TypedWorkSpace<double> work(m);
904 TypedWorkSpace<std::complex<double> > za(m*n);
905
906 // Copy float matrix in Lapack full storage format into temporary
907 // dense double matrix.
908 for (int j=0; j<n; j++)
909 for (int i=0; i<m; i++)
910 za.data[j*m + i] = a[j*lda + i];
911 // leading dimension of za.data is m now, not lda
912 return zlange_( norm, m, n, za.data, m, work.data, 1 );
913 }
914
915 template <>
lange(const char & norm,const int & m,const int & n,const std::complex<double> * a,const int & lda)916 double LapackInterface::lange<std::complex<double> >( const char& norm, const int& m, const int& n, const std::complex<double>* a, const int& lda) {
917 TypedWorkSpace<double> work(m);
918 return( zlange_( norm, m, n, a, lda, work.data, 1 ) );
919 }
920
921 template <>
ormqr(const char & side,const char & trans,const int & m,const int & n,const int & k,float * a,const int & lda,float * tau,float * c__,const int & ldc,float * work,const int & lwork,int & info)922 void LapackInterface::ormqr<float>(const char& side, const char& trans, const int& m, const int& n, const int& k, float* a, const int& lda, float *tau, float *c__, const int& ldc, float* work, const int& lwork, int& info) {
923
924 sormqr_( side, trans, m, n, k, a, lda, tau, c__, ldc, work, lwork, info, 1, 1 );
925
926 if( info < 0 ) {
927 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "sormqr", info );
928 }
929 return;
930 }
931
932 template <>
ormqr(const char & side,const char & trans,const int & m,const int & n,const int & k,double * a,const int & lda,double * tau,double * c__,const int & ldc,double * work,const int & lwork,int & info)933 void LapackInterface::ormqr<double>(const char& side, const char& trans, const int& m, const int& n, const int& k, double* a, const int& lda, double *tau, double *c__, const int& ldc, double* work, const int& lwork, int& info) {
934
935 dormqr_( side, trans, m, n, k, a, lda, tau, c__, ldc, work, lwork, info, 1, 1 );
936
937 if( info < 0 ) {
938 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dormqr", info );
939 }
940 return;
941 }
942
943 template <>
ormqr(const char & side,const char & trans,const int & m,const int & n,const int & k,std::complex<double> * a,const int & lda,std::complex<double> * tau,std::complex<double> * c__,const int & ldc,std::complex<double> * work,const int & lwork,int & info)944 void LapackInterface::ormqr<std::complex<double> >(const char& side, const char& trans, const int& m, const int& n, const int& k, std::complex<double>* a, const int& lda, std::complex<double> *tau, std::complex<double> *c__, const int& ldc, std::complex<double>* work, const int& lwork, int& info) {
945
946 zunmqr_( side, trans, m, n, k, a, lda, tau, c__, ldc, work, lwork, info, 1, 1 );
947
948 if( info < 0 ) {
949 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zunmqr", info );
950 }
951 return;
952 }
953
954 template <>
ormqr(const char & side,const char & trans,const int & m,const int & n,const int & k,std::complex<float> * a,const int & lda,std::complex<float> * tau,std::complex<float> * c__,const int & ldc,std::complex<float> * work,const int & lwork,int & info)955 void LapackInterface::ormqr<std::complex<float> >(const char& side, const char& trans, const int& m, const int& n, const int& k, std::complex<float>* a, const int& lda, std::complex<float> *tau, std::complex<float> *c__, const int& ldc, std::complex<float>* work, const int& lwork, int& info) {
956
957 cunmqr_( side, trans, m, n, k, a, lda, tau, c__, ldc, work, lwork, info, 1, 1 );
958
959 if( info < 0 ) {
960 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "cunmqr", info );
961 }
962 return;
963 }
964
965 template <>
trsm(const char & side,const char & uplo,const char & transA,const char & diag,const int & m,const int & n,const float & alpha,const float * a,const int & lda,float * b,const int & ldb)966 void LapackInterface::trsm<float>(const char& side, const char& uplo, const char& transA, const char& diag, const int& m, const int& n, const float& alpha, const float* a, const int& lda, float* b, const int& ldb ) {
967 strsm_( side, uplo, transA, diag, m, n, alpha, a, lda, b, ldb, 1, 1, 1 );
968 return;
969 }
970
971 template <>
trsm(const char & side,const char & uplo,const char & transA,const char & diag,const int & m,const int & n,const double & alpha,const double * a,const int & lda,double * b,const int & ldb)972 void LapackInterface::trsm<double>(const char& side, const char& uplo, const char& transA, const char& diag, const int& m, const int& n, const double& alpha, const double* a, const int& lda, double* b, const int& ldb ) {
973 dtrsm_( side, uplo, transA, diag, m, n, alpha, a, lda, b, ldb, 1, 1, 1 );
974 return;
975 }
976
977 template <>
trsm(const char & side,const char & uplo,const char & transA,const char & diag,const int & m,const int & n,const std::complex<double> & alpha,const std::complex<double> * a,const int & lda,std::complex<double> * b,const int & ldb)978 void LapackInterface::trsm<std::complex<double> >(const char& side, const char& uplo, const char& transA, const char& diag, const int& m, const int& n, const std::complex<double>& alpha, const std::complex<double>* a, const int& lda, std::complex<double>* b, const int& ldb ) {
979 ztrsm_( side, uplo, transA, diag, m, n, alpha, a, lda, b, ldb, 1, 1, 1 );
980 return;
981 }
982
983 template <>
trsm(const char & side,const char & uplo,const char & transA,const char & diag,const int & m,const int & n,const std::complex<float> & alpha,const std::complex<float> * a,const int & lda,std::complex<float> * b,const int & ldb)984 void LapackInterface::trsm<std::complex<float> >(const char& side, const char& uplo, const char& transA, const char& diag, const int& m, const int& n, const std::complex<float>& alpha, const std::complex<float>* a, const int& lda, std::complex<float>* b, const int& ldb ) {
985 ctrsm_( side, uplo, transA, diag, m, n, alpha, a, lda, b, ldb, 1, 1, 1 );
986 return;
987 }
988 template <>
ormrz(const char & side,const char & trans,const int & m,const int & n,const int & k,const int & l,float * a,const int & lda,float * tau,float * c__,const int & ldc,float * work,const int & lwork,int & info)989 void LapackInterface::ormrz<float>(const char& side, const char& trans, const int& m, const int& n, const int& k, const int& l, float* a, const int& lda, float* tau, float* c__, const int& ldc, float* work, const int& lwork, int& info) {
990 sormrz_( side, trans, m, n, k, l, a, lda, tau, c__, ldc, work, lwork, info, 1, 1 );
991
992 if( info < 0 ) {
993 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "sormrz", info );
994 }
995 return;
996 }
997
998 template <>
ormrz(const char & side,const char & trans,const int & m,const int & n,const int & k,const int & l,double * a,const int & lda,double * tau,double * c__,const int & ldc,double * work,const int & lwork,int & info)999 void LapackInterface::ormrz<double>(const char& side, const char& trans, const int& m, const int& n, const int& k, const int& l, double* a, const int& lda, double* tau, double* c__, const int& ldc, double* work, const int& lwork, int& info) {
1000 dormrz_( side, trans, m, n, k, l, a, lda, tau, c__, ldc, work, lwork, info, 1, 1 );
1001
1002 if( info < 0 ) {
1003 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dormrz", info );
1004 }
1005 return;
1006 }
1007
1008 template <>
ormrz(const char & side,const char & trans,const int & m,const int & n,const int & k,const int & l,std::complex<float> * a,const int & lda,std::complex<float> * tau,std::complex<float> * c__,const int & ldc,std::complex<float> * work,const int & lwork,int & info)1009 void LapackInterface::ormrz<std::complex<float> >(const char& side, const char& trans, const int& m, const int& n, const int& k, const int& l, std::complex<float>* a, const int& lda, std::complex<float>* tau, std::complex<float>* c__, const int& ldc, std::complex<float>* work, const int& lwork, int& info) {
1010 cunmrz_( side, trans, m, n, k, l, a, lda, tau, c__, ldc, work, lwork, info, 1, 1 );
1011
1012 if( info < 0 ) {
1013 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "cunmrz", info );
1014 }
1015 return;
1016 }
1017
1018 template <>
ormrz(const char & side,const char & trans,const int & m,const int & n,const int & k,const int & l,std::complex<double> * a,const int & lda,std::complex<double> * tau,std::complex<double> * c__,const int & ldc,std::complex<double> * work,const int & lwork,int & info)1019 void LapackInterface::ormrz<std::complex<double> >(const char& side, const char& trans, const int& m, const int& n, const int& k, const int& l, std::complex<double>* a, const int& lda, std::complex<double>* tau, std::complex<double>* c__, const int& ldc, std::complex<double>* work, const int& lwork, int& info) {
1020 zunmrz_( side, trans, m, n, k, l, a, lda, tau, c__, ldc, work, lwork, info, 1, 1 );
1021
1022 if( info < 0 ) {
1023 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zunmrz", info );
1024 }
1025 return;
1026 }
1027
1028 template <>
copy(const int & n,const float * x,const int & incx,float * y,const int & incy)1029 void LapackInterface::copy<float>( const int& n, const float* x, const int& incx, float* y, const int& incy) {
1030 scopy_(n, x, incx, y, incy );
1031 return;
1032 }
1033
1034 template <>
copy(const int & n,const double * x,const int & incx,double * y,const int & incy)1035 void LapackInterface::copy<double>( const int& n, const double* x, const int& incx, double* y, const int& incy) {
1036 dcopy_(n, x, incx, y, incy );
1037 return;
1038 }
1039
1040 template <>
copy(const int & n,const std::complex<float> * x,const int & incx,std::complex<float> * y,const int & incy)1041 void LapackInterface::copy<std::complex<float> >( const int& n, const std::complex<float>* x, const int& incx, std::complex<float>* y, const int& incy) {
1042 ccopy_(n, x, incx, y, incy );
1043 return;
1044 }
1045
1046 template <>
copy(const int & n,const std::complex<double> * x,const int & incx,std::complex<double> * y,const int & incy)1047 void LapackInterface::copy<std::complex<double> >( const int& n, const std::complex<double>* x, const int& incx, std::complex<double>* y, const int& incy) {
1048 zcopy_(n, x, incx, y, incy );
1049 return;
1050 }
1051 template <>
getMachineUnderflow(float & underFlow)1052 void LapackInterface::getMachineUnderflow<float>( float& underFlow ) {
1053 underFlow = slamch_('S');
1054 return;
1055 }
1056 template <>
getMachineUnderflow(double & underFlow)1057 void LapackInterface::getMachineUnderflow<double>( double& underFlow ) {
1058 underFlow = dlamch_('S');
1059 return;
1060 }
1061 template <>
getMachinePrecision(float & smallNumber,float & bigNumber)1062 void LapackInterface::getMachinePrecision<float>( float& smallNumber, float& bigNumber ) {
1063
1064 smallNumber = slamch_( 'S' )/slamch_( 'P' );
1065 bigNumber = 1.f/smallNumber;
1066 slabad_(smallNumber, bigNumber );
1067 }
1068
1069 template <>
getMachinePrecision(double & smallNumber,double & bigNumber)1070 void LapackInterface::getMachinePrecision<double>( double& smallNumber, double& bigNumber ) {
1071
1072 smallNumber = dlamch_( 'S' )/dlamch_( 'P' );
1073 bigNumber = 1.0/smallNumber;
1074 dlabad_(smallNumber, bigNumber );
1075 }
1076
1077 template <>
laic1(const int & job,const int & j,const float * x,const float & sest,const float * w,const float & gamma,float & sestpr,float & s,float & c__)1078 void LapackInterface::laic1<float>(const int& job, const int& j, const float* x, const float& sest, const float* w, const float& gamma, float& sestpr, float& s, float& c__ ) {
1079 slaic1_( job, j, x, sest, w, gamma, sestpr, s, c__ );
1080 return;
1081 }
1082
1083 template <>
laic1(const int & job,const int & j,const double * x,const double & sest,const double * w,const double & gamma,double & sestpr,double & s,double & c__)1084 void LapackInterface::laic1<double>(const int& job, const int& j, const double* x, const double& sest, const double* w, const double& gamma, double& sestpr, double& s, double& c__ ) {
1085 dlaic1_( job, j, x, sest, w, gamma, sestpr, s, c__ );
1086 return;
1087 }
1088
1089 template <>
laic1(const int & job,const int & j,const std::complex<float> * x,const float & sest,const std::complex<float> * w,const std::complex<float> & gamma,float & sestpr,std::complex<float> & s,std::complex<float> & c__)1090 void LapackInterface::laic1<std::complex<float> >(const int& job, const int& j, const std::complex<float>* x, const float& sest, const std::complex<float>* w, const std::complex<float>& gamma, float& sestpr, std::complex<float>& s, std::complex<float>& c__ ) {
1091 claic1_( job, j, x, sest, w, gamma, sestpr, s, c__ );
1092 return;
1093 }
1094
1095
1096 template <>
laic1(const int & job,const int & j,const std::complex<double> * x,const double & sest,const std::complex<double> * w,const std::complex<double> & gamma,double & sestpr,std::complex<double> & s,std::complex<double> & c__)1097 void LapackInterface::laic1<std::complex<double> >(const int& job, const int& j, const std::complex<double>* x, const double& sest, const std::complex<double>* w, const std::complex<double>& gamma, double& sestpr, std::complex<double>& s, std::complex<double>& c__ ) {
1098 zlaic1_( job, j, x, sest, w, gamma, sestpr, s, c__ );
1099 return;
1100 }
1101
1102 template <>
potrf(const char & uplo,const int n,double * a,const int lda,int & info)1103 void LapackInterface::potrf<double>( const char& uplo, const int n, double* a, const int lda, int& info ) {
1104
1105 dpotrf_(uplo, n, a, lda, info);
1106 if( info < 0 ) {
1107 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dpotrf", info );
1108 }
1109
1110 return;
1111 }
1112 template <>
potrf(const char & uplo,const int n,float * a,const int lda,int & info)1113 void LapackInterface::potrf<float>( const char& uplo, const int n, float* a, const int lda, int& info ) {
1114
1115 spotrf_(uplo, n, a, lda, info);
1116 if( info < 0 ) {
1117 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "spotrf", info );
1118 }
1119
1120 return;
1121 }
1122 template <>
potrf(const char & uplo,const int n,std::complex<double> * a,const int lda,int & info)1123 void LapackInterface::potrf<std::complex<double> >( const char& uplo, const int n, std::complex<double>* a, const int lda, int& info ) {
1124
1125 zpotrf_(uplo, n, a, lda, info);
1126 if( info < 0 ) {
1127 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zpotrf", info );
1128 }
1129
1130 return;
1131 }
1132 template <>
potrf(const char & uplo,const int n,std::complex<float> * a,const int lda,int & info)1133 void LapackInterface::potrf<std::complex<float> >( const char& uplo, const int n, std::complex<float>* a, const int lda, int& info ) {
1134
1135 cpotrf_(uplo, n, a, lda, info);
1136
1137 if( info < 0 ) {
1138 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "cpotrf", info );
1139 }
1140
1141 return;
1142 }
1143 template <>
sytrf(const char & uplo,const int n,float * a,const int lda,int * pivots,float * work,const int lwork,int & info)1144 void LapackInterface::sytrf<float>( const char& uplo, const int n, float* a, const int lda, int* pivots, float* work, const int lwork, int& info){
1145
1146 ssytrf_( uplo, n, a, lda, pivots, work, lwork, info );
1147
1148 if( info < 0 ) {
1149 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "ssytrf", info );
1150 }
1151 return;
1152 }
1153 template <>
sytrf(const char & uplo,const int n,double * a,const int lda,int * pivots,double * work,const int lwork,int & info)1154 void LapackInterface::sytrf<double>( const char& uplo, const int n, double* a, const int lda, int* pivots, double* work, const int lwork, int& info){
1155
1156 dsytrf_( uplo, n, a, lda, pivots, work, lwork, info );
1157
1158 if( info < 0 ) {
1159 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "dsytrf", info );
1160 }
1161 return;
1162 }
1163 template <>
sytrf(const char & uplo,const int n,std::complex<double> * a,const int lda,int * pivots,std::complex<double> * work,const int lwork,int & info)1164 void LapackInterface::sytrf<std::complex<double> >( const char& uplo, const int n, std::complex<double>* a, const int lda, int* pivots, std::complex<double>* work, const int lwork, int& info){
1165
1166 zsytrf_( uplo, n, a, lda, pivots, work, lwork, info );
1167
1168 if( info < 0 ) {
1169 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "zsytrf", info );
1170 }
1171 return;
1172 }
1173 template <>
sytrf(const char & uplo,const int n,std::complex<float> * a,const int lda,int * pivots,std::complex<float> * work,const int lwork,int & info)1174 void LapackInterface::sytrf<std::complex<float> >( const char& uplo, const int n, std::complex<float>* a, const int lda, int* pivots, std::complex<float>* work, const int lwork, int& info){
1175
1176 csytrf_( uplo, n, a, lda, pivots, work, lwork, info );
1177
1178 if( info < 0 ) {
1179 SimTK_THROW2( SimTK::Exception::IllegalLapackArg, "csytrf", info );
1180 }
1181 return;
1182 }
1183 template <typename T>
sytrf(const char & uplo,const int n,T * a,const int lda,int * pivots,T * work,const int lwork,int & info)1184 void LapackInterface::sytrf( const char& uplo, const int n, T* a, const int lda, int *pivots, T* work, const int lwork, int& info ) { assert(false); }
1185
1186 template <>
ilaenv(const int & ispec,const char * name,const char * opts,const int & n1,const int & n2,const int & n3,const int & n4)1187 int LapackInterface::ilaenv<double>( const int& ispec, const char* name, const char *opts, const int& n1, const int& n2, const int& n3, const int& n4 ) {
1188 char d[10];
1189 d[0] = 'd';
1190 d[1] = '\0';
1191 return (ilaenv_( ispec, strcat( d, name), opts, n1, n2, n3, n3, 6, (int)strlen(opts)) );
1192 }
1193 template <>
ilaenv(const int & ispec,const char * name,const char * opts,const int & n1,const int & n2,const int & n3,const int & n4)1194 int LapackInterface::ilaenv<float>( const int& ispec, const char* name, const char *opts, const int& n1, const int& n2, const int& n3, const int& n4 ) {
1195 char s[10];
1196 s[0] = 's';
1197 s[1] = '\0';
1198 return (ilaenv_( ispec, strcat( s, name), opts, n1, n2, n3, n3, 6, (int)strlen(opts)) );
1199 }
1200 template <>
ilaenv(const int & ispec,const char * name,const char * opts,const int & n1,const int & n2,const int & n3,const int & n4)1201 int LapackInterface::ilaenv<std::complex<double> >( const int& ispec, const char* name, const char *opts, const int& n1, const int& n2, const int& n3, const int& n4 ) {
1202 char z[10];
1203 z[0] = 'z';
1204 z[1] = '\0';
1205 return (ilaenv_( ispec, strcat( z, name), opts, n1, n2, n3, n3, 6, (int)strlen(opts)) );
1206 }
1207 template <>
ilaenv(const int & ispec,const char * name,const char * opts,const int & n1,const int & n2,const int & n3,const int & n4)1208 int LapackInterface::ilaenv<std::complex<float> >( const int& ispec, const char* name, const char *opts, const int& n1, const int& n2, const int& n3, const int& n4 ) {
1209 char c[10];
1210 c[0] = 'c';
1211 c[1] = '\0';
1212 return (ilaenv_( ispec, strcat( c, name), opts, n1, n2, n3, n3, 6, (int)strlen(opts)) );
1213 }
1214
1215
1216 } // namespace SimTK
1217
1218