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 (2008) Sandia Corporation
00006 // 
00007 // Under the terms of Contract DE-AC04-94AL85000 with Sandia Corporation,
00008 // the U.S. Government retains certain rights in this software.
00009 // 
00010 // Redistribution and use in source and binary forms, with or without
00011 // modification, are permitted provided that the following conditions are
00012 // met:
00013 //
00014 // 1. Redistributions of source code must retain the above copyright
00015 // notice, this list of conditions and the following disclaimer.
00016 //
00017 // 2. Redistributions in binary form must reproduce the above copyright
00018 // notice, this list of conditions and the following disclaimer in the
00019 // documentation and/or other materials provided with the distribution.
00020 //
00021 // 3. Neither the name of the Corporation nor the names of the
00022 // contributors may be used to endorse or promote products derived from
00023 // this software without specific prior written permission.
00024 //
00025 // THIS SOFTWARE IS PROVIDED BY SANDIA CORPORATION "AS IS" AND ANY
00026 // EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
00027 // IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
00028 // PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL SANDIA CORPORATION OR THE
00029 // CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
00030 // EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
00031 // PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
00032 // PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
00033 // LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
00034 // NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
00035 // SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
00036 //
00037 // Questions? Contact Michael A. Heroux (maherou@sandia.gov) 
00038 // 
00039 // ************************************************************************
00040 //@HEADER
00041 
00042 #include <Tsqr_Lapack.hpp>
00043 
00044 
00045 extern "C" void F77_BLAS_MANGLE(slarnv, SLARNV)
00046   (const int* const IDIST,
00047    int ISEED[],
00048    const int* const N,
00049    float X[]);
00050 
00051 extern "C" void F77_BLAS_MANGLE(spotri, SPOTRI)
00052   (const char* const UPLO,
00053    const int* const N,
00054    float A[],
00055    const int* const LDA,
00056    int* const INFO);
00057 
00058 extern "C" void F77_BLAS_MANGLE(spotrf, SPOTRF)
00059   (const char* const UPLO,
00060    const int* const N,
00061    float A[],
00062    const int* const LDA,
00063    int* const INFO);
00064 
00065 extern "C" void F77_BLAS_MANGLE(spotrs, SPOTRS)
00066   (const char* const UPLO,
00067    const int* const N,
00068    const int* const NRHS,
00069    const float A[],
00070    const int* const LDA,
00071    float B[],
00072    const int* const LDB,
00073    int* const INFO);
00074 
00075 #ifdef HAVE_LAPACK_SLARFGP
00076 extern "C" void F77_BLAS_MANGLE(slarfgp,SLARFGP)
00077   (const int* const N,    // IN
00078    float* const ALPHA,   // IN/OUT
00079    float X[],            // IN/OUT
00080    const int* const INCX, // IN
00081    float* const TAU);    // OUT
00082 #else
00083 #  ifdef HAVE_LAPACK_SLARFP
00084 extern "C" void F77_BLAS_MANGLE(slarfp,SLARFP)
00085   (const int* const N,    // IN
00086    float* const ALPHA,   // IN/OUT
00087    float X[],            // IN/OUT
00088    const int* const INCX, // IN
00089    float* const TAU);    // OUT
00090 #  else
00091 extern "C" void F77_BLAS_MANGLE(slarfg,SLARFG)
00092   (const int* const N,    // IN
00093    float* const ALPHA,   // IN/OUT
00094    float X[],            // IN/OUT
00095    const int* const INCX, // IN
00096    float* const TAU);    // OUT
00097 #  endif // HAVE_LAPACK_SLARFP
00098 #endif // HAVE_LAPACK_SLARFGP
00099 
00100 extern "C" void F77_BLAS_MANGLE(sgeqrf, SGEQRF)
00101   (const int* const M,
00102    const int* const N,
00103    float A[],
00104    const int* const LDA,
00105    float TAU[],
00106    float WORK[],
00107    const int* const LWORK,
00108    int* const INFO);
00109 
00110 #ifdef HAVE_LAPACK_SGEQRFP
00111 extern "C" void F77_BLAS_MANGLE(sgeqrfp, SGEQRFP)
00112   (const int* const M,
00113    const int* const N,
00114    float A[],
00115    const int* const LDA,
00116    float TAU[],
00117    float WORK[],
00118    const int* const LWORK,
00119    int* const INFO);
00120 #endif // HAVE_LAPACK_SGEQRFP
00121 
00122 extern "C" void F77_BLAS_MANGLE(sgeqr2, SGEQR2)
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 
00131 #ifdef HAVE_LAPACK_SGEQR2P
00132 extern "C" void F77_BLAS_MANGLE(sgeqr2p, SGEQR2P)
00133   (const int* const M,
00134    const int* const N,
00135    float A[],
00136    const int* const LDA,
00137    float TAU[],
00138    float WORK[],
00139    int* const INFO);
00140 #endif // HAVE_LAPACK_SGEQR2P
00141 
00142 extern "C" void F77_BLAS_MANGLE(sormqr, SORMQR)
00143   (const char* const SIDE,
00144    const char* const TRANS,
00145    const int* const M,
00146    const int* const N,
00147    const int* const K,
00148    const float A[],
00149    const int* const LDA,
00150    const float TAU[],
00151    float C[],
00152    const int* const LDC,
00153    float WORK[],
00154    const int* const LWORK,
00155    int* const INFO);
00156 
00157 extern "C" void F77_BLAS_MANGLE(sorm2r, SORM2R)
00158   (const char* const SIDE,
00159    const char* const TRANS,
00160    const int* const M,
00161    const int* const N,
00162    const int* const K,
00163    const float A[],
00164    const int* const LDA,
00165    const float TAU[],
00166    float C[],
00167    const int* const LDC,
00168    float WORK[],
00169    int* const INFO);
00170 
00171 extern "C" void F77_BLAS_MANGLE(sorgqr, SORGQR)
00172   (const int* const M,
00173    const int* const N,
00174    const int* const K,
00175    float A[],
00176    const int* const LDA,
00177    float TAU[],
00178    float WORK[],
00179    const int* const LWORK,
00180    int* const INFO);
00181 
00182 extern "C" void F77_BLAS_MANGLE(sgesvd, SGESVD) 
00183   (const char* const JOBU, 
00184    const char* const JOBVT, 
00185    const int* const M, 
00186    const int* const N, 
00187    float A[], 
00188    const int* const LDA,
00189    float S[], 
00190    float U[], 
00191    const int* const LDU, 
00192    float VT[], 
00193    const int* const LDVT, 
00194    float work[],
00195    const int* const LWORK,
00196    float RWORK[],
00197    int* const INFO);
00198 
00201 
00202 namespace TSQR {
00203 
00204   // If _GEQRFP is available, LAPACK::GEQRF() calls it.  If _LARFP is
00205   // available, LAPACK::GEQRF() calls _GEQRF, which uses _LARFP.
00206 #ifdef HAVE_LAPACK_SGEQRFP
00207   template <>
00208   bool LAPACK<int, float >::QR_produces_R_factor_with_nonnegative_diagonal() { return true; }
00209 #else // Don't HAVE_LAPACK_SGEQRFP
00210 #  ifdef HAVE_LAPACK_SLARFP
00211   template <>
00212   bool LAPACK<int, float >::QR_produces_R_factor_with_nonnegative_diagonal() { return true; }
00213 #  else
00214   template <>
00215   bool LAPACK<int, float >::QR_produces_R_factor_with_nonnegative_diagonal() { return false; }
00216 #  endif
00217 #endif
00218 
00220   // LARFP (implemented with _LARFGP if available, else with _LARFP if
00221   // available, else fall back to _LARFG)
00223   template <>
00224   void 
00225   LAPACK<int, float >::LARFP (const int n, 
00226             float& alpha, 
00227             float x[], 
00228             const int incx, 
00229             float& tau)
00230   {
00231 #ifdef HAVE_LAPACK_SLARFGP
00232     F77_BLAS_MANGLE(slarfgp,SLARFGP) (&n, &alpha, x, &incx, &tau);
00233 #else // Don't HAVE_LAPACK_SLARFGP
00234 #  ifdef HAVE_LAPACK_SLARFP
00235     F77_BLAS_MANGLE(slarfp,SLARFP) (&n, &alpha, x, &incx, &tau);
00236 #  else
00237     F77_BLAS_MANGLE(slarfg,SLARFG) (&n, &alpha, x, &incx, &tau);
00238 #  endif // HAVE_LAPACK_SLARFP
00239 #endif // HAVE_LAPACK_SLARFGP
00240   }
00241 
00243   // GEQRF (implemented with _GEQRFP if available, else fall back to _GEQRF)
00245   template <>
00246   void
00247   LAPACK<int, float >::GEQRF (const int m,
00248             const int n, 
00249             float A[],
00250             const int lda, 
00251             float tau[],
00252             float work[],
00253             const int lwork,
00254             int* const INFO)
00255   {
00256 #ifdef HAVE_LAPACK_SGEQRFP
00257     F77_BLAS_MANGLE(sgeqrfp, SGEQRFP) 
00258       (&m, &n, A, &lda, tau, work, &lwork, INFO);
00259 #else
00260     F77_BLAS_MANGLE(sgeqrf, SGEQRF) 
00261       (&m, &n, A, &lda, tau, work, &lwork, INFO);
00262 #endif // HAVE_LAPACK_SGEQRFP
00263   }
00264 
00266   // GEQR2 (implemented with _GEQR2P if available, else fall back to _GEQR2)
00268   template <>
00269   void
00270   LAPACK<int, float >::GEQR2 (const int m,
00271             const int n, 
00272             float A[],
00273             const int lda, 
00274             float tau[],
00275             float work[],
00276             int* const INFO)
00277   {
00278 #ifdef HAVE_LAPACK_SGEQR2P
00279     F77_BLAS_MANGLE(sgeqr2p, SGEQR2P) (&m, &n, A, &lda, tau, work, INFO);
00280 #else
00281     F77_BLAS_MANGLE(sgeqr2, SGEQR2) (&m, &n, A, &lda, tau, work, INFO);
00282 #endif // HAVE_LAPACK_SGEQR2P
00283   }
00284 
00285   template <>
00286   void
00287   LAPACK<int, float >::ORMQR (const char* const side,
00288             const char* const trans,
00289             const int m,
00290             const int n,
00291             const int k,
00292             const float A[],
00293             const int lda,
00294             const float tau[],
00295             float C[],
00296             const int ldc,
00297             float work[],
00298             const int lwork,
00299             int* const INFO)
00300   {
00301     F77_BLAS_MANGLE(sormqr, SORMQR) 
00302       (side, trans, &m, &n, &k, A, &lda, tau, C, &ldc, work, &lwork, INFO);
00303   }
00304 
00305   template <>
00306   void
00307   LAPACK<int, float >::ORM2R (const char* const side,
00308             const char* const trans,
00309             const int m,
00310             const int n,
00311             const int k,
00312             const float A[],
00313             const int lda,
00314             const float tau[],
00315             float C[],
00316             const int ldc,
00317             float work[],
00318             int* const INFO)
00319   {
00320     F77_BLAS_MANGLE(sorm2r, SORM2R) 
00321       (side, trans, &m, &n, &k, A, &lda, tau, C, &ldc, work, INFO);
00322   }
00323 
00324   template <>
00325   void
00326   LAPACK<int, float >::ORGQR (const int m,
00327             const int n,
00328             const int k,
00329             float A[],
00330             const int lda,
00331             float tau[],
00332             float work[],
00333             const int lwork,
00334             int* const INFO)
00335   {
00336     F77_BLAS_MANGLE(sorgqr, SORGQR) 
00337       (&m, &n, &k, A, &lda, tau, work, &lwork, INFO);
00338   }
00339 
00340   template <>
00341   void
00342   LAPACK<int, float >::POTRF (const char* const uplo,
00343             const int n,
00344             float A[],
00345             const int lda,
00346             int* const INFO)
00347   {
00348     F77_BLAS_MANGLE(spotrf, SPOTRF) (uplo, &n, A, &lda, INFO);
00349   }
00350 
00351   template <>
00352   void
00353   LAPACK<int, float >::POTRS (const char* const uplo,
00354             const int n,
00355             const int nrhs,
00356             const float A[],
00357             const int lda,
00358             float B[],
00359             const int ldb,
00360             int* const INFO)
00361   {
00362     F77_BLAS_MANGLE(spotrs, SPOTRS) (uplo, &n, &nrhs, A, &lda, B, &ldb, INFO);
00363   }
00364 
00365   template <>
00366   void
00367   LAPACK<int, float >::POTRI (const char* const uplo, 
00368             const int n, 
00369             float A[], 
00370             const int lda, 
00371             int* const INFO)
00372   {
00373     F77_BLAS_MANGLE(spotri, SPOTRI) (uplo, &n, A, &lda, INFO);
00374   }
00375 
00376   template <>
00377   void
00378   LAPACK<int, float >::LARNV (const int idist, 
00379             int iseed[],
00380             const int n,
00381             float x[])
00382   {
00383     F77_BLAS_MANGLE(slarnv, SLARNV) (&idist, iseed, &n, x);
00384   }
00385 
00386   template <>
00387   void
00388   LAPACK<int, float >::GESVD (const char* const jobu,
00389             const char* const jobvt,
00390             const int m,
00391             const int n,
00392             float A[],
00393             const int lda,
00394             float s[],
00395             float U[],
00396             const int ldu,
00397             float VT[],
00398             const int ldvt,
00399             float work[],
00400             const int lwork,
00401             float rwork[],
00402             int* const INFO)
00403   {
00404     F77_BLAS_MANGLE(sgesvd, SGESVD) (jobu, jobvt, &m, &n, 
00405              A, &lda, s, 
00406              U, &ldu, VT, &ldvt, 
00407              work, &lwork, rwork, INFO);
00408   }
00409 
00410 } // namespace TSQR
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends