38 #ifndef GMM_LAPACK_INTERFACE_H
39 #define GMM_LAPACK_INTERFACE_H
45 #if defined(GMM_USES_LAPACK) && !defined(GMM_MATLAB_INTERFACE)
87 void sgetrf_(...);
void dgetrf_(...);
void cgetrf_(...);
void zgetrf_(...);
88 void sgetrs_(...);
void dgetrs_(...);
void cgetrs_(...);
void zgetrs_(...);
89 void sgetri_(...);
void dgetri_(...);
void cgetri_(...);
void zgetri_(...);
90 void sgeqrf_(...);
void dgeqrf_(...);
void cgeqrf_(...);
void zgeqrf_(...);
91 void sorgqr_(...);
void dorgqr_(...);
void cungqr_(...);
void zungqr_(...);
92 void sormqr_(...);
void dormqr_(...);
void cunmqr_(...);
void zunmqr_(...);
93 void sgees_ (...);
void dgees_ (...);
void cgees_ (...);
void zgees_ (...);
94 void sgeev_ (...);
void dgeev_ (...);
void cgeev_ (...);
void zgeev_ (...);
95 void sgeesx_(...);
void dgeesx_(...);
void cgeesx_(...);
void zgeesx_(...);
96 void sgesvd_(...);
void dgesvd_(...);
void cgesvd_(...);
void zgesvd_(...);
103 # define getrf_interface(lapack_name, base_type) inline \
104 size_type lu_factor(dense_matrix<base_type> &A, lapack_ipvt &ipvt) { \
105 GMMLAPACK_TRACE("getrf_interface"); \
106 const BLAS_INT m=BLAS_INT(mat_nrows(A)), n=BLAS_INT(mat_ncols(A)), lda(m);\
108 if (m && n) lapack_name(&m, &n, &A(0,0), &lda, &ipvt[0], &info); \
109 return size_type(abs(info)); \
112 getrf_interface(sgetrf_, BLAS_S)
113 getrf_interface(dgetrf_, BLAS_D)
114 getrf_interface(cgetrf_, BLAS_C)
115 getrf_interface(zgetrf_, BLAS_Z)
121 # define getrs_interface(f_name, trans, lapack_name, base_type) inline \
122 void f_name(const dense_matrix<base_type> &A, \
123 const lapack_ipvt &ipvt, std::vector<base_type> &x, \
124 const std::vector<base_type> &b) { \
125 GMMLAPACK_TRACE("getrs_interface"); \
126 const BLAS_INT n=BLAS_INT(mat_nrows(A)), nrhs(1); \
127 BLAS_INT info(0); gmm::copy(b, x); trans; \
129 lapack_name(&t, &n, &nrhs, &A(0,0), &n, &ipvt[0], &x[0], &n, &info); \
132 # define getrs_trans_n const char t = 'N'
133 # define getrs_trans_t const char t = 'T'
135 getrs_interface(lu_solve, getrs_trans_n, sgetrs_, BLAS_S)
136 getrs_interface(lu_solve, getrs_trans_n, dgetrs_, BLAS_D)
137 getrs_interface(lu_solve, getrs_trans_n, cgetrs_, BLAS_C)
138 getrs_interface(lu_solve, getrs_trans_n, zgetrs_, BLAS_Z)
139 getrs_interface(lu_solve_transposed, getrs_trans_t, sgetrs_, BLAS_S)
140 getrs_interface(lu_solve_transposed, getrs_trans_t, dgetrs_, BLAS_D)
141 getrs_interface(lu_solve_transposed, getrs_trans_t, cgetrs_, BLAS_C)
142 getrs_interface(lu_solve_transposed, getrs_trans_t, zgetrs_, BLAS_Z)
148 # define getri_interface(lapack_name, base_type) \
149 inline void lu_inverse(const dense_matrix<base_type> &LU, \
150 const lapack_ipvt &ipvt, \
151 dense_matrix<base_type> &A) { \
152 GMMLAPACK_TRACE("getri_interface"); \
153 const BLAS_INT n=BLAS_INT(mat_nrows(A)); \
154 BLAS_INT info(0), lwork(-1); base_type work1; \
157 lapack_name(&n, &A(0,0), &n, &ipvt[0], &work1, &lwork, &info); \
158 lwork = int(gmm::real(work1)); \
159 std::vector<base_type> work(lwork); \
160 lapack_name(&n, &A(0,0), &n, &ipvt[0], &work[0], &lwork, &info); \
164 getri_interface(sgetri_, BLAS_S)
165 getri_interface(dgetri_, BLAS_D)
166 getri_interface(cgetri_, BLAS_C)
167 getri_interface(zgetri_, BLAS_Z)
173 # define geqrf_interface(lapack_name, base_type) \
174 inline void qr_factor(dense_matrix<base_type> &A) { \
175 GMMLAPACK_TRACE("geqrf_interface"); \
176 const BLAS_INT m=BLAS_INT(mat_nrows(A)), n=BLAS_INT(mat_ncols(A)); \
177 BLAS_INT info(0), lwork(-1); base_type work1; \
179 std::vector<base_type> tau(n); \
180 lapack_name(&m, &n, &A(0,0), &m, &tau[0], &work1, &lwork, &info); \
181 lwork = BLAS_INT(gmm::real(work1)); \
182 std::vector<base_type> work(lwork); \
183 lapack_name(&m, &n, &A(0,0), &m, &tau[0], &work[0], &lwork, &info); \
184 GMM_ASSERT1(!info, "QR factorization failed"); \
188 geqrf_interface(sgeqrf_, BLAS_S)
189 geqrf_interface(dgeqrf_, BLAS_D)
195 # define geqrf_interface2(lapack_name1, lapack_name2, base_type) inline \
196 void qr_factor(const dense_matrix<base_type> &A, \
197 dense_matrix<base_type> &Q, dense_matrix<base_type> &R) { \
198 GMMLAPACK_TRACE("geqrf_interface2"); \
199 const BLAS_INT m=BLAS_INT(mat_nrows(A)), n=BLAS_INT(mat_ncols(A)); \
200 BLAS_INT info(0), lwork(-1); base_type work1; \
202 std::copy(A.begin(), A.end(), Q.begin()); \
203 std::vector<base_type> tau(n); \
204 lapack_name1(&m, &n, &Q(0,0), &m, &tau[0], &work1 , &lwork, &info); \
205 lwork = BLAS_INT(gmm::real(work1)); \
206 std::vector<base_type> work(lwork); \
207 lapack_name1(&m, &n, &Q(0,0), &m, &tau[0], &work[0], &lwork, &info); \
208 GMM_ASSERT1(!info, "QR factorization failed"); \
209 base_type *p = &R(0,0), *q = &Q(0,0); \
210 for (BLAS_INT j = 0; j < n; ++j, q += m-n) \
211 for (BLAS_INT i = 0; i < n; ++i, ++p, ++q) \
212 *p = (j < i) ? base_type(0) : *q; \
213 lapack_name2(&m, &n, &n, &Q(0,0), &m,&tau[0],&work[0],&lwork,&info); \
215 else gmm::clear(Q); \
218 geqrf_interface2(sgeqrf_, sorgqr_, BLAS_S)
219 geqrf_interface2(dgeqrf_, dorgqr_, BLAS_D)
220 geqrf_interface2(cgeqrf_, cungqr_, BLAS_C)
221 geqrf_interface2(zgeqrf_, zungqr_, BLAS_Z)
227 # define gees_interface(lapack_name, base_type) \
228 template <typename VECT> inline void implicit_qr_algorithm( \
229 const dense_matrix<base_type> &A, VECT &eigval_, \
230 dense_matrix<base_type> &Q, \
231 double tol=gmm::default_tol(base_type()), bool compvect = true) { \
232 GMMLAPACK_TRACE("gees_interface"); \
233 typedef bool (*L_fp)(...); L_fp p = 0; \
234 BLAS_INT n=BLAS_INT(mat_nrows(A)), info(0), lwork(-1), sdim; \
237 dense_matrix<base_type> H(n,n); gmm::copy(A, H); \
238 char jobvs = (compvect ? 'V' : 'N'), sort = 'N'; \
239 std::vector<double> rwork(n), eigv1(n), eigv2(n); \
240 lapack_name(&jobvs, &sort, p, &n, &H(0,0), &n, &sdim, &eigv1[0], \
241 &eigv2[0], &Q(0,0), &n, &work1, &lwork, &rwork[0], &info); \
242 lwork = BLAS_INT(gmm::real(work1)); \
243 std::vector<base_type> work(lwork); \
244 lapack_name(&jobvs, &sort, p, &n, &H(0,0), &n, &sdim, &eigv1[0], \
245 &eigv2[0], &Q(0,0), &n, &work[0], &lwork, &rwork[0],&info);\
246 GMM_ASSERT1(!info, "QR algorithm failed"); \
247 extract_eig(H, eigval_, tol); \
250 # define gees_interface2(lapack_name, base_type) \
251 template <typename VECT> inline void implicit_qr_algorithm( \
252 const dense_matrix<base_type> &A, VECT &eigval_, \
253 dense_matrix<base_type> &Q, \
254 double tol=gmm::default_tol(base_type()), bool compvect = true) { \
255 GMMLAPACK_TRACE("gees_interface2"); \
256 typedef bool (*L_fp)(...); L_fp p = 0; \
257 BLAS_INT n=BLAS_INT(mat_nrows(A)), info(0), lwork(-1), sdim; \
260 dense_matrix<base_type> H(n,n); gmm::copy(A, H); \
261 char jobvs = (compvect ? 'V' : 'N'), sort = 'N'; \
262 std::vector<double> rwork(n), eigvv(n*2); \
263 lapack_name(&jobvs, &sort, p, &n, &H(0,0), &n, &sdim, &eigvv[0], \
264 &Q(0,0), &n, &work1, &lwork, &rwork[0], &rwork[0], &info); \
265 lwork = BLAS_INT(gmm::real(work1)); \
266 std::vector<base_type> work(lwork); \
267 lapack_name(&jobvs, &sort, p, &n, &H(0,0), &n, &sdim, &eigvv[0], \
268 &Q(0,0), &n, &work[0], &lwork, &rwork[0], &rwork[0],&info);\
269 GMM_ASSERT1(!info, "QR algorithm failed"); \
270 extract_eig(H, eigval_, tol); \
273 gees_interface(sgees_, BLAS_S)
274 gees_interface(dgees_, BLAS_D)
275 gees_interface2(cgees_, BLAS_C)
276 gees_interface2(zgees_, BLAS_Z)
279 # define jobv_right char jobvl = 'N', jobvr = 'V';
280 # define jobv_left char jobvl = 'V', jobvr = 'N';
282 # define geev_interface(lapack_name, base_type, side) \
283 template <typename VECT> inline void geev_interface_ ## side( \
284 const dense_matrix<base_type> &A, VECT &eigval_, \
285 dense_matrix<base_type> &Q) { \
286 GMMLAPACK_TRACE("geev_interface"); \
287 BLAS_INT n = BLAS_INT(mat_nrows(A)), info(0), lwork(-1); \
290 dense_matrix<base_type> H(n,n); gmm::copy(A, H); \
292 std::vector<base_type> eigvr(n), eigvi(n); \
293 lapack_name(&jobvl, &jobvr, &n, &H(0,0), &n, &eigvr[0], &eigvi[0], \
294 &Q(0,0), &n, &Q(0,0), &n, &work1, &lwork, &info); \
295 lwork = BLAS_INT(gmm::real(work1)); \
296 std::vector<base_type> work(lwork); \
297 lapack_name(&jobvl, &jobvr, &n, &H(0,0), &n, &eigvr[0], &eigvi[0], \
298 &Q(0,0), &n, &Q(0,0), &n, &work[0], &lwork, &info); \
299 GMM_ASSERT1(!info, "QR algorithm failed"); \
300 gmm::copy(eigvr, gmm::real_part(eigval_)); \
301 gmm::copy(eigvi, gmm::imag_part(eigval_)); \
304 # define geev_interface2(lapack_name, base_type, side) \
305 template <typename VECT> inline void geev_interface_ ## side( \
306 const dense_matrix<base_type> &A, VECT &eigval_, \
307 dense_matrix<base_type> &Q) { \
308 GMMLAPACK_TRACE("geev_interface"); \
309 BLAS_INT n = BLAS_INT(mat_nrows(A)), info(0), lwork(-1); \
312 dense_matrix<base_type> H(n,n); gmm::copy(A, H); \
314 std::vector<base_type::value_type> rwork(2*n); \
315 std::vector<base_type> eigv(n); \
316 lapack_name(&jobvl, &jobvr, &n, &H(0,0), &n, &eigv[0], &Q(0,0), &n, \
317 &Q(0,0), &n, &work1, &lwork, &rwork[0], &info); \
318 lwork = BLAS_INT(gmm::real(work1)); \
319 std::vector<base_type> work(lwork); \
320 lapack_name(&jobvl, &jobvr, &n, &H(0,0), &n, &eigv[0], &Q(0,0), &n, \
321 &Q(0,0), &n, &work[0], &lwork, &rwork[0], &info); \
322 GMM_ASSERT1(!info, "QR algorithm failed"); \
323 gmm::copy(eigv, eigval_); \
326 geev_interface(sgeev_, BLAS_S, right)
327 geev_interface(dgeev_, BLAS_D, right)
328 geev_interface2(cgeev_, BLAS_C, right)
329 geev_interface2(zgeev_, BLAS_Z, right)
331 geev_interface(sgeev_, BLAS_S, left)
332 geev_interface(dgeev_, BLAS_D, left)
333 geev_interface2(cgeev_, BLAS_C, left)
334 geev_interface2(zgeev_, BLAS_Z, left)
342 # define geesx_interface(lapack_name, base_type) \
343 inline void schur(dense_matrix<base_type> &A, \
344 dense_matrix<base_type> &S, \
345 dense_matrix<base_type> &Q) { \
346 GMMLAPACK_TRACE("geesx_interface"); \
347 const BLAS_INT m=BLAS_INT(mat_nrows(A)), n=BLAS_INT(mat_ncols(A)); \
348 GMM_ASSERT1(m == n, "Schur decomposition requires square matrix"); \
349 char jobvs = 'V', sort = 'N', sense = 'N'; \
350 bool select = false; \
351 BLAS_INT lwork = 8*n, sdim = 0, liwork = 1; \
352 std::vector<base_type> work(lwork), wr(n), wi(n); \
353 std::vector<BLAS_INT> iwork(liwork); \
354 std::vector<BLAS_INT> bwork(1); \
355 resize(S, n, n); copy(A, S); \
357 base_type rconde(0), rcondv(0); \
359 lapack_name(&jobvs, &sort, &select, &sense, &n, &S(0,0), &n, \
360 &sdim, &wr[0], &wi[0], &Q(0,0), &n, &rconde, &rcondv, \
361 &work[0], &lwork, &iwork[0], &liwork, &bwork[0], &info);\
362 GMM_ASSERT1(!info, "SCHUR algorithm failed"); \
365 # define geesx_interface2(lapack_name, base_type) \
366 inline void schur(dense_matrix<base_type> &A, \
367 dense_matrix<base_type> &S, \
368 dense_matrix<base_type> &Q) { \
369 GMMLAPACK_TRACE("geesx_interface"); \
370 const BLAS_INT m=BLAS_INT(mat_nrows(A)), n=BLAS_INT(mat_ncols(A)); \
371 GMM_ASSERT1(m == n, "Schur decomposition requires square matrix"); \
372 char jobvs = 'V', sort = 'N', sense = 'N'; \
373 bool select = false; \
374 BLAS_INT lwork = 8*n, sdim = 0; \
375 std::vector<base_type::value_type> rwork(lwork); \
376 std::vector<base_type> work(lwork), w(n); \
377 std::vector<BLAS_INT> bwork(1); \
378 resize(S, n, n); copy(A, S); \
380 base_type rconde(0), rcondv(0); \
382 lapack_name(&jobvs, &sort, &select, &sense, &n, &S(0,0), &n, \
383 &sdim, &w[0], &Q(0,0), &n, &rconde, &rcondv, \
384 &work[0], &lwork, &rwork[0], &bwork[0], &info); \
385 GMM_ASSERT1(!info, "SCHUR algorithm failed"); \
388 geesx_interface(sgeesx_, BLAS_S)
389 geesx_interface(dgeesx_, BLAS_D)
390 geesx_interface2(cgeesx_, BLAS_C)
391 geesx_interface2(zgeesx_, BLAS_Z)
393 template <
typename MAT>
394 void schur(
const MAT &A_, MAT &S, MAT &Q) {
405 # define gesvd_interface(lapack_name, base_type) \
406 inline void svd(dense_matrix<base_type> &X, \
407 dense_matrix<base_type> &U, \
408 dense_matrix<base_type> &Vtransposed, \
409 std::vector<base_type> &sigma) { \
410 GMMLAPACK_TRACE("gesvd_interface"); \
411 BLAS_INT m = BLAS_INT(mat_nrows(X)), n = BLAS_INT(mat_ncols(X)); \
412 BLAS_INT mn_min = m < n ? m : n; \
413 sigma.resize(mn_min); \
414 std::vector<base_type> work(15 * mn_min); \
415 BLAS_INT lwork = BLAS_INT(work.size()); \
417 resize(Vtransposed, n, n); \
420 lapack_name(&job, &job, &m, &n, &X(0,0), &m, &sigma[0], &U(0,0), \
421 &m, &Vtransposed(0,0), &n, &work[0], &lwork, &info); \
424 # define cgesvd_interface(lapack_name, base_type, base_type2) \
425 inline void svd(dense_matrix<base_type> &X, \
426 dense_matrix<base_type> &U, \
427 dense_matrix<base_type> &Vtransposed, \
428 std::vector<base_type2> &sigma) { \
429 GMMLAPACK_TRACE("gesvd_interface"); \
430 BLAS_INT m = BLAS_INT(mat_nrows(X)), n = BLAS_INT(mat_ncols(X)); \
431 BLAS_INT mn_min = m < n ? m : n; \
432 sigma.resize(mn_min); \
433 std::vector<base_type> work(15 * mn_min); \
434 std::vector<base_type2> rwork(5 * mn_min); \
435 BLAS_INT lwork = BLAS_INT(work.size()); \
437 resize(Vtransposed, n, n); \
440 lapack_name(&job, &job, &m, &n, &X(0,0), &m, &sigma[0], &U(0,0), \
441 &m, &Vtransposed(0,0), &n, &work[0], &lwork, \
445 gesvd_interface(sgesvd_, BLAS_S)
446 gesvd_interface(dgesvd_, BLAS_D)
447 cgesvd_interface(cgesvd_, BLAS_C, BLAS_S)
448 cgesvd_interface(zgesvd_, BLAS_Z, BLAS_D)
450 template <
typename MAT,
typename VEC>
451 void svd(
const MAT &X_, MAT &U, MAT &Vtransposed, VEC &sigma) {
453 svd(X, U, Vtransposed, sigma);
462 template <
typename MAT>
463 void schur(
const MAT &, MAT &, MAT &)
465 GMM_ASSERT1(
false,
"Use of function schur(A,S,Q) requires GetFEM "
466 "to be built with Lapack");
469 template <
typename BLAS_TYPE>
470 inline void svd(dense_matrix<BLAS_TYPE> &, dense_matrix<BLAS_TYPE> &,
471 dense_matrix<BLAS_TYPE> &, std::vector<BLAS_TYPE> &)
473 GMM_ASSERT1(
false,
"Use of function svd(X,U,Vtransposed,sigma) requires GetFEM "
474 "to be built with Lapack");
gmm interface for fortran BLAS.
LU factorizations and determinant computation for dense matrices.