Anasazi Version of the Day
Tsqr_SLapack.cpp
00001 // @HEADER
00002 // ***********************************************************************
00003 //
00004 //                 Anasazi: Block Eigensolvers Package
00005 //                 Copyright (2010) Sandia Corporation
00006 //
00007 // Under terms of Contract DE-AC04-94AL85000, there is a non-exclusive
00008 // license for use of this work by or on behalf of the U.S. Government.
00009 //
00010 // This library is free software; you can redistribute it and/or modify
00011 // it under the terms of the GNU Lesser General Public License as
00012 // published by the Free Software Foundation; either version 2.1 of the
00013 // License, or (at your option) any later version.
00014 //
00015 // This library is distributed in the hope that it will be useful, but
00016 // WITHOUT ANY WARRANTY; without even the implied warranty of
00017 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00018 // Lesser General Public License for more details.
00019 //
00020 // You should have received a copy of the GNU Lesser General Public
00021 // License along with this library; if not, write to the Free Software
00022 // Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
00023 // USA
00024 // Questions? Contact Michael A. Heroux (maherou@sandia.gov)
00025 //
00026 // ***********************************************************************
00027 // @HEADER
00028 
00029 #include <Tsqr_Lapack.hpp>
00030 #include <Tsqr_Config.hpp>
00031 
00034 
00035 extern "C" void F77_BLAS_MANGLE(slarnv, SLARNV)
00036   (const int* const IDIST,
00037    int ISEED[],
00038    const int* const N,
00039    float X[]);
00040 
00041 extern "C" void F77_BLAS_MANGLE(spotri, SPOTRI)
00042   (const char* const UPLO,
00043    const int* const N,
00044    float A[],
00045    const int* const LDA,
00046    int* const INFO);
00047 
00048 extern "C" void F77_BLAS_MANGLE(spotrf, SPOTRF)
00049   (const char* const UPLO,
00050    const int* const N,
00051    float A[],
00052    const int* const LDA,
00053    int* const INFO);
00054 
00055 extern "C" void F77_BLAS_MANGLE(spotrs, SPOTRS)
00056   (const char* const UPLO,
00057    const int* const N,
00058    const int* const NRHS,
00059    const float A[],
00060    const int* const LDA,
00061    float B[],
00062    const int* const LDB,
00063    int* const INFO);
00064 
00065 #ifdef HAVE_LAPACK_SLARFGP
00066 extern "C" void F77_BLAS_MANGLE(slarfgp,SLARFGP)
00067   (const int* const N,    // IN
00068    float* const ALPHA,   // IN/OUT
00069    float X[],            // IN/OUT
00070    const int* const INCX, // IN
00071    float* const TAU);    // OUT
00072 #else
00073 #  ifdef HAVE_LAPACK_SLARFP
00074 extern "C" void F77_BLAS_MANGLE(slarfp,SLARFP)
00075   (const int* const N,    // IN
00076    float* const ALPHA,   // IN/OUT
00077    float X[],            // IN/OUT
00078    const int* const INCX, // IN
00079    float* const TAU);    // OUT
00080 #  else
00081 extern "C" void F77_BLAS_MANGLE(slarfg,SLARFG)
00082   (const int* const N,    // IN
00083    float* const ALPHA,   // IN/OUT
00084    float X[],            // IN/OUT
00085    const int* const INCX, // IN
00086    float* const TAU);    // OUT
00087 #  endif // HAVE_LAPACK_SLARFP
00088 #endif // HAVE_LAPACK_SLARFGP
00089 
00090 extern "C" void F77_BLAS_MANGLE(sgeqrf, SGEQRF)
00091   (const int* const M,
00092    const int* const N,
00093    float A[],
00094    const int* const LDA,
00095    float TAU[],
00096    float WORK[],
00097    const int* const LWORK,
00098    int* const INFO);
00099 
00100 #ifdef HAVE_LAPACK_SGEQRFP
00101 extern "C" void F77_BLAS_MANGLE(sgeqrfp, SGEQRFP)
00102   (const int* const M,
00103    const int* const N,
00104    float A[],
00105    const int* const LDA,
00106    float TAU[],
00107    float WORK[],
00108    const int* const LWORK,
00109    int* const INFO);
00110 #endif // HAVE_LAPACK_SGEQRFP
00111 
00112 extern "C" void F77_BLAS_MANGLE(sgeqr2, SGEQR2)
00113   (const int* const M,
00114    const int* const N,
00115    float A[],
00116    const int* const LDA,
00117    float TAU[],
00118    float WORK[],
00119    int* const INFO);
00120 
00121 #ifdef HAVE_LAPACK_SGEQR2P
00122 extern "C" void F77_BLAS_MANGLE(sgeqr2p, SGEQR2P)
00123   (const int* const M,
00124    const int* const N,
00125    float A[],
00126    const int* const LDA,
00127    float TAU[],
00128    float WORK[],
00129    int* const INFO);
00130 #endif // HAVE_LAPACK_SGEQR2P
00131 
00132 extern "C" void F77_BLAS_MANGLE(sormqr, SORMQR)
00133   (const char* const SIDE,
00134    const char* const TRANS,
00135    const int* const M,
00136    const int* const N,
00137    const int* const K,
00138    const float A[],
00139    const int* const LDA,
00140    const float TAU[],
00141    float C[],
00142    const int* const LDC,
00143    float WORK[],
00144    const int* const LWORK,
00145    int* const INFO);
00146 
00147 extern "C" void F77_BLAS_MANGLE(sorm2r, SORM2R)
00148   (const char* const SIDE,
00149    const char* const TRANS,
00150    const int* const M,
00151    const int* const N,
00152    const int* const K,
00153    const float A[],
00154    const int* const LDA,
00155    const float TAU[],
00156    float C[],
00157    const int* const LDC,
00158    float WORK[],
00159    int* const INFO);
00160 
00161 extern "C" void F77_BLAS_MANGLE(sorgqr, SORGQR)
00162   (const int* const M,
00163    const int* const N,
00164    const int* const K,
00165    float A[],
00166    const int* const LDA,
00167    float TAU[],
00168    float WORK[],
00169    const int* const LWORK,
00170    int* const INFO);
00171 
00172 extern "C" void F77_BLAS_MANGLE(sgesvd, SGESVD) 
00173   (const char* const JOBU, 
00174    const char* const JOBVT, 
00175    const int* const M, 
00176    const int* const N, 
00177    float A[], 
00178    const int* const LDA,
00179    float S[], 
00180    float U[], 
00181    const int* const LDU, 
00182    float VT[], 
00183    const int* const LDVT, 
00184    float work[],
00185    const int* const LWORK,
00186    float RWORK[],
00187    int* const INFO);
00188 
00191 
00192 namespace TSQR {
00193 
00194   // If _GEQRFP is available, LAPACK::GEQRF() calls it.  If _LARFP is
00195   // available, LAPACK::GEQRF() calls _GEQRF, which uses _LARFP.
00196 #ifdef HAVE_LAPACK_SGEQRFP
00197   template <>
00198   bool LAPACK<int, float >::QR_produces_R_factor_with_nonnegative_diagonal() { return true; }
00199 #else // Don't HAVE_LAPACK_SGEQRFP
00200 #  ifdef HAVE_LAPACK_SLARFP
00201   template <>
00202   bool LAPACK<int, float >::QR_produces_R_factor_with_nonnegative_diagonal() { return true; }
00203 #  else
00204   template <>
00205   bool LAPACK<int, float >::QR_produces_R_factor_with_nonnegative_diagonal() { return false; }
00206 #  endif
00207 #endif
00208 
00210   // LARFP (implemented with _LARFGP if available, else with _LARFP if
00211   // available, else fall back to _LARFG)
00213   template <>
00214   void 
00215   LAPACK<int, float >::LARFP (const int n, 
00216             float& alpha, 
00217             float x[], 
00218             const int incx, 
00219             float& tau)
00220   {
00221 #ifdef HAVE_LAPACK_SLARFGP
00222     F77_BLAS_MANGLE(slarfgp,SLARFGP) (&n, &alpha, x, &incx, &tau);
00223 #else // Don't HAVE_LAPACK_SLARFGP
00224 #  ifdef HAVE_LAPACK_SLARFP
00225     F77_BLAS_MANGLE(slarfp,SLARFP) (&n, &alpha, x, &incx, &tau);
00226 #  else
00227     F77_BLAS_MANGLE(slarfg,SLARFG) (&n, &alpha, x, &incx, &tau);
00228 #  endif // HAVE_LAPACK_SLARFP
00229 #endif // HAVE_LAPACK_SLARFGP
00230   }
00231 
00233   // GEQRF (implemented with _GEQRFP if available, else fall back to _GEQRF)
00235   template <>
00236   void
00237   LAPACK<int, float >::GEQRF (const int m,
00238             const int n, 
00239             float A[],
00240             const int lda, 
00241             float tau[],
00242             float work[],
00243             const int lwork,
00244             int* const INFO)
00245   {
00246 #ifdef HAVE_LAPACK_SGEQRFP
00247     F77_BLAS_MANGLE(sgeqrfp, SGEQRFP) 
00248       (&m, &n, A, &lda, tau, work, &lwork, INFO);
00249 #else
00250     F77_BLAS_MANGLE(sgeqrf, SGEQRF) 
00251       (&m, &n, A, &lda, tau, work, &lwork, INFO);
00252 #endif // HAVE_LAPACK_SGEQRFP
00253   }
00254 
00256   // GEQR2 (implemented with _GEQR2P if available, else fall back to _GEQR2)
00258   template <>
00259   void
00260   LAPACK<int, float >::GEQR2 (const int m,
00261             const int n, 
00262             float A[],
00263             const int lda, 
00264             float tau[],
00265             float work[],
00266             int* const INFO)
00267   {
00268 #ifdef HAVE_LAPACK_SGEQR2P
00269     F77_BLAS_MANGLE(sgeqr2p, SGEQR2P) (&m, &n, A, &lda, tau, work, INFO);
00270 #else
00271     F77_BLAS_MANGLE(sgeqr2, SGEQR2) (&m, &n, A, &lda, tau, work, INFO);
00272 #endif // HAVE_LAPACK_SGEQR2P
00273   }
00274 
00275   template <>
00276   void
00277   LAPACK<int, float >::ORMQR (const char* const side,
00278             const char* const trans,
00279             const int m,
00280             const int n,
00281             const int k,
00282             const float A[],
00283             const int lda,
00284             const float tau[],
00285             float C[],
00286             const int ldc,
00287             float work[],
00288             const int lwork,
00289             int* const INFO)
00290   {
00291     F77_BLAS_MANGLE(sormqr, SORMQR) 
00292       (side, trans, &m, &n, &k, A, &lda, tau, C, &ldc, work, &lwork, INFO);
00293   }
00294 
00295   template <>
00296   void
00297   LAPACK<int, float >::ORM2R (const char* const side,
00298             const char* const trans,
00299             const int m,
00300             const int n,
00301             const int k,
00302             const float A[],
00303             const int lda,
00304             const float tau[],
00305             float C[],
00306             const int ldc,
00307             float work[],
00308             int* const INFO)
00309   {
00310     F77_BLAS_MANGLE(sorm2r, SORM2R) 
00311       (side, trans, &m, &n, &k, A, &lda, tau, C, &ldc, work, INFO);
00312   }
00313 
00314   template <>
00315   void
00316   LAPACK<int, float >::ORGQR (const int m,
00317             const int n,
00318             const int k,
00319             float A[],
00320             const int lda,
00321             float tau[],
00322             float work[],
00323             const int lwork,
00324             int* const INFO)
00325   {
00326     F77_BLAS_MANGLE(sorgqr, SORGQR) 
00327       (&m, &n, &k, A, &lda, tau, work, &lwork, INFO);
00328   }
00329 
00330   template <>
00331   void
00332   LAPACK<int, float >::POTRF (const char* const uplo,
00333             const int n,
00334             float A[],
00335             const int lda,
00336             int* const INFO)
00337   {
00338     F77_BLAS_MANGLE(spotrf, SPOTRF) (uplo, &n, A, &lda, INFO);
00339   }
00340 
00341   template <>
00342   void
00343   LAPACK<int, float >::POTRS (const char* const uplo,
00344             const int n,
00345             const int nrhs,
00346             const float A[],
00347             const int lda,
00348             float B[],
00349             const int ldb,
00350             int* const INFO)
00351   {
00352     F77_BLAS_MANGLE(spotrs, SPOTRS) (uplo, &n, &nrhs, A, &lda, B, &ldb, INFO);
00353   }
00354 
00355   template <>
00356   void
00357   LAPACK<int, float >::POTRI (const char* const uplo, 
00358             const int n, 
00359             float A[], 
00360             const int lda, 
00361             int* const INFO)
00362   {
00363     F77_BLAS_MANGLE(spotri, SPOTRI) (uplo, &n, A, &lda, INFO);
00364   }
00365 
00366   template <>
00367   void
00368   LAPACK<int, float >::LARNV (const int idist, 
00369             int iseed[],
00370             const int n,
00371             float x[])
00372   {
00373     F77_BLAS_MANGLE(slarnv, SLARNV) (&idist, iseed, &n, x);
00374   }
00375 
00376   template <>
00377   void
00378   LAPACK<int, float >::GESVD (const char* const jobu,
00379             const char* const jobvt,
00380             const int m,
00381             const int n,
00382             float A[],
00383             const int lda,
00384             float s[],
00385             float U[],
00386             const int ldu,
00387             float VT[],
00388             const int ldvt,
00389             float work[],
00390             const int lwork,
00391             float rwork[],
00392             int* const INFO)
00393   {
00394     F77_BLAS_MANGLE(sgesvd, SGESVD) (jobu, jobvt, &m, &n, 
00395              A, &lda, s, 
00396              U, &ldu, VT, &ldvt, 
00397              work, &lwork, rwork, INFO);
00398   }
00399 
00400 } // namespace TSQR
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends