Kokkos Node API and Local Linear Algebra Kernels Version of the Day
Tsqr_SLapack.cpp
00001 //@HEADER
00002 // ************************************************************************
00003 // 
00004 //          Kokkos: Node API and Parallel Node Kernels
00005 //              Copyright (2009) 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 
00031 
00032 extern "C" void F77_BLAS_MANGLE(slarnv, SLARNV)
00033   (const int* const IDIST,
00034    int ISEED[],
00035    const int* const N,
00036    float X[]);
00037 
00038 extern "C" void F77_BLAS_MANGLE(spotri, SPOTRI)
00039   (const char* const UPLO,
00040    const int* const N,
00041    float A[],
00042    const int* const LDA,
00043    int* const INFO);
00044 
00045 extern "C" void F77_BLAS_MANGLE(spotrf, SPOTRF)
00046   (const char* const UPLO,
00047    const int* const N,
00048    float A[],
00049    const int* const LDA,
00050    int* const INFO);
00051 
00052 extern "C" void F77_BLAS_MANGLE(spotrs, SPOTRS)
00053   (const char* const UPLO,
00054    const int* const N,
00055    const int* const NRHS,
00056    const float A[],
00057    const int* const LDA,
00058    float B[],
00059    const int* const LDB,
00060    int* const INFO);
00061 
00062 #ifdef HAVE_LAPACK_SLARFGP
00063 extern "C" void F77_BLAS_MANGLE(slarfgp,SLARFGP)
00064   (const int* const N,    // IN
00065    float* const ALPHA,   // IN/OUT
00066    float X[],            // IN/OUT
00067    const int* const INCX, // IN
00068    float* const TAU);    // OUT
00069 #else
00070 #  ifdef HAVE_LAPACK_SLARFP
00071 extern "C" void F77_BLAS_MANGLE(slarfp,SLARFP)
00072   (const int* const N,    // IN
00073    float* const ALPHA,   // IN/OUT
00074    float X[],            // IN/OUT
00075    const int* const INCX, // IN
00076    float* const TAU);    // OUT
00077 #  else
00078 extern "C" void F77_BLAS_MANGLE(slarfg,SLARFG)
00079   (const int* const N,    // IN
00080    float* const ALPHA,   // IN/OUT
00081    float X[],            // IN/OUT
00082    const int* const INCX, // IN
00083    float* const TAU);    // OUT
00084 #  endif // HAVE_LAPACK_SLARFP
00085 #endif // HAVE_LAPACK_SLARFGP
00086 
00087 extern "C" void F77_BLAS_MANGLE(sgeqrf, SGEQRF)
00088   (const int* const M,
00089    const int* const N,
00090    float A[],
00091    const int* const LDA,
00092    float TAU[],
00093    float WORK[],
00094    const int* const LWORK,
00095    int* const INFO);
00096 
00097 #ifdef HAVE_LAPACK_SGEQRFP
00098 extern "C" void F77_BLAS_MANGLE(sgeqrfp, SGEQRFP)
00099   (const int* const M,
00100    const int* const N,
00101    float A[],
00102    const int* const LDA,
00103    float TAU[],
00104    float WORK[],
00105    const int* const LWORK,
00106    int* const INFO);
00107 #endif // HAVE_LAPACK_SGEQRFP
00108 
00109 extern "C" void F77_BLAS_MANGLE(sgeqr2, SGEQR2)
00110   (const int* const M,
00111    const int* const N,
00112    float A[],
00113    const int* const LDA,
00114    float TAU[],
00115    float WORK[],
00116    int* const INFO);
00117 
00118 #ifdef HAVE_LAPACK_SGEQR2P
00119 extern "C" void F77_BLAS_MANGLE(sgeqr2p, SGEQR2P)
00120   (const int* const M,
00121    const int* const N,
00122    float A[],
00123    const int* const LDA,
00124    float TAU[],
00125    float WORK[],
00126    int* const INFO);
00127 #endif // HAVE_LAPACK_SGEQR2P
00128 
00129 extern "C" void F77_BLAS_MANGLE(sormqr, SORMQR)
00130   (const char* const SIDE,
00131    const char* const TRANS,
00132    const int* const M,
00133    const int* const N,
00134    const int* const K,
00135    const float A[],
00136    const int* const LDA,
00137    const float TAU[],
00138    float C[],
00139    const int* const LDC,
00140    float WORK[],
00141    const int* const LWORK,
00142    int* const INFO);
00143 
00144 extern "C" void F77_BLAS_MANGLE(sorm2r, SORM2R)
00145   (const char* const SIDE,
00146    const char* const TRANS,
00147    const int* const M,
00148    const int* const N,
00149    const int* const K,
00150    const float A[],
00151    const int* const LDA,
00152    const float TAU[],
00153    float C[],
00154    const int* const LDC,
00155    float WORK[],
00156    int* const INFO);
00157 
00158 extern "C" void F77_BLAS_MANGLE(sorgqr, SORGQR)
00159   (const int* const M,
00160    const int* const N,
00161    const int* const K,
00162    float A[],
00163    const int* const LDA,
00164    float TAU[],
00165    float WORK[],
00166    const int* const LWORK,
00167    int* const INFO);
00168 
00169 extern "C" void F77_BLAS_MANGLE(sgesvd, SGESVD) 
00170   (const char* const JOBU, 
00171    const char* const JOBVT, 
00172    const int* const M, 
00173    const int* const N, 
00174    float A[], 
00175    const int* const LDA,
00176    float S[], 
00177    float U[], 
00178    const int* const LDU, 
00179    float VT[], 
00180    const int* const LDVT, 
00181    float work[],
00182    const int* const LWORK,
00183    float RWORK[],
00184    int* const INFO);
00185 
00188 
00189 namespace TSQR {
00190 
00191   // If _GEQRFP is available, LAPACK::GEQRF() calls it.  If _LARFP is
00192   // available, LAPACK::GEQRF() calls _GEQRF, which uses _LARFP.
00193 #ifdef HAVE_LAPACK_SGEQRFP
00194   template <>
00195   bool LAPACK<int, float >::QR_produces_R_factor_with_nonnegative_diagonal() { return true; }
00196 #else // Don't HAVE_LAPACK_SGEQRFP
00197 #  ifdef HAVE_LAPACK_SLARFP
00198   template <>
00199   bool LAPACK<int, float >::QR_produces_R_factor_with_nonnegative_diagonal() { return true; }
00200 #  else
00201   template <>
00202   bool LAPACK<int, float >::QR_produces_R_factor_with_nonnegative_diagonal() { return false; }
00203 #  endif
00204 #endif
00205 
00207   // LARFP (implemented with _LARFGP if available, else with _LARFP if
00208   // available, else fall back to _LARFG)
00210   template <>
00211   void 
00212   LAPACK<int, float >::LARFP (const int n, 
00213             float& alpha, 
00214             float x[], 
00215             const int incx, 
00216             float& tau)
00217   {
00218 #ifdef HAVE_LAPACK_SLARFGP
00219     F77_BLAS_MANGLE(slarfgp,SLARFGP) (&n, &alpha, x, &incx, &tau);
00220 #else // Don't HAVE_LAPACK_SLARFGP
00221 #  ifdef HAVE_LAPACK_SLARFP
00222     F77_BLAS_MANGLE(slarfp,SLARFP) (&n, &alpha, x, &incx, &tau);
00223 #  else
00224     F77_BLAS_MANGLE(slarfg,SLARFG) (&n, &alpha, x, &incx, &tau);
00225 #  endif // HAVE_LAPACK_SLARFP
00226 #endif // HAVE_LAPACK_SLARFGP
00227   }
00228 
00230   // GEQRF (implemented with _GEQRFP if available, else fall back to _GEQRF)
00232   template <>
00233   void
00234   LAPACK<int, float >::GEQRF (const int m,
00235             const int n, 
00236             float A[],
00237             const int lda, 
00238             float tau[],
00239             float work[],
00240             const int lwork,
00241             int* const INFO)
00242   {
00243 #ifdef HAVE_LAPACK_SGEQRFP
00244     F77_BLAS_MANGLE(sgeqrfp, SGEQRFP) 
00245       (&m, &n, A, &lda, tau, work, &lwork, INFO);
00246 #else
00247     F77_BLAS_MANGLE(sgeqrf, SGEQRF) 
00248       (&m, &n, A, &lda, tau, work, &lwork, INFO);
00249 #endif // HAVE_LAPACK_SGEQRFP
00250   }
00251 
00253   // GEQR2 (implemented with _GEQR2P if available, else fall back to _GEQR2)
00255   template <>
00256   void
00257   LAPACK<int, float >::GEQR2 (const int m,
00258             const int n, 
00259             float A[],
00260             const int lda, 
00261             float tau[],
00262             float work[],
00263             int* const INFO)
00264   {
00265 #ifdef HAVE_LAPACK_SGEQR2P
00266     F77_BLAS_MANGLE(sgeqr2p, SGEQR2P) (&m, &n, A, &lda, tau, work, INFO);
00267 #else
00268     F77_BLAS_MANGLE(sgeqr2, SGEQR2) (&m, &n, A, &lda, tau, work, INFO);
00269 #endif // HAVE_LAPACK_SGEQR2P
00270   }
00271 
00272   template <>
00273   void
00274   LAPACK<int, float >::ORMQR (const char* const side,
00275             const char* const trans,
00276             const int m,
00277             const int n,
00278             const int k,
00279             const float A[],
00280             const int lda,
00281             const float tau[],
00282             float C[],
00283             const int ldc,
00284             float work[],
00285             const int lwork,
00286             int* const INFO)
00287   {
00288     F77_BLAS_MANGLE(sormqr, SORMQR) 
00289       (side, trans, &m, &n, &k, A, &lda, tau, C, &ldc, work, &lwork, INFO);
00290   }
00291 
00292   template <>
00293   void
00294   LAPACK<int, float >::ORM2R (const char* const side,
00295             const char* const trans,
00296             const int m,
00297             const int n,
00298             const int k,
00299             const float A[],
00300             const int lda,
00301             const float tau[],
00302             float C[],
00303             const int ldc,
00304             float work[],
00305             int* const INFO)
00306   {
00307     F77_BLAS_MANGLE(sorm2r, SORM2R) 
00308       (side, trans, &m, &n, &k, A, &lda, tau, C, &ldc, work, INFO);
00309   }
00310 
00311   template <>
00312   void
00313   LAPACK<int, float >::ORGQR (const int m,
00314             const int n,
00315             const int k,
00316             float A[],
00317             const int lda,
00318             float tau[],
00319             float work[],
00320             const int lwork,
00321             int* const INFO)
00322   {
00323     F77_BLAS_MANGLE(sorgqr, SORGQR) 
00324       (&m, &n, &k, A, &lda, tau, work, &lwork, INFO);
00325   }
00326 
00327   template <>
00328   void
00329   LAPACK<int, float >::POTRF (const char* const uplo,
00330             const int n,
00331             float A[],
00332             const int lda,
00333             int* const INFO)
00334   {
00335     F77_BLAS_MANGLE(spotrf, SPOTRF) (uplo, &n, A, &lda, INFO);
00336   }
00337 
00338   template <>
00339   void
00340   LAPACK<int, float >::POTRS (const char* const uplo,
00341             const int n,
00342             const int nrhs,
00343             const float A[],
00344             const int lda,
00345             float B[],
00346             const int ldb,
00347             int* const INFO)
00348   {
00349     F77_BLAS_MANGLE(spotrs, SPOTRS) (uplo, &n, &nrhs, A, &lda, B, &ldb, INFO);
00350   }
00351 
00352   template <>
00353   void
00354   LAPACK<int, float >::POTRI (const char* const uplo, 
00355             const int n, 
00356             float A[], 
00357             const int lda, 
00358             int* const INFO)
00359   {
00360     F77_BLAS_MANGLE(spotri, SPOTRI) (uplo, &n, A, &lda, INFO);
00361   }
00362 
00363   template <>
00364   void
00365   LAPACK<int, float >::LARNV (const int idist, 
00366             int iseed[],
00367             const int n,
00368             float x[])
00369   {
00370     F77_BLAS_MANGLE(slarnv, SLARNV) (&idist, iseed, &n, x);
00371   }
00372 
00373   template <>
00374   void
00375   LAPACK<int, float >::GESVD (const char* const jobu,
00376             const char* const jobvt,
00377             const int m,
00378             const int n,
00379             float A[],
00380             const int lda,
00381             float s[],
00382             float U[],
00383             const int ldu,
00384             float VT[],
00385             const int ldvt,
00386             float work[],
00387             const int lwork,
00388             float rwork[],
00389             int* const INFO)
00390   {
00391     F77_BLAS_MANGLE(sgesvd, SGESVD) (jobu, jobvt, &m, &n, 
00392              A, &lda, s, 
00393              U, &ldu, VT, &ldvt, 
00394              work, &lwork, rwork, INFO);
00395   }
00396 
00397 } // namespace TSQR
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends