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