Kokkos Node API and Local Linear Algebra Kernels Version of the Day
Tsqr_DLapack.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 extern "C" void F77_BLAS_MANGLE(dlarnv, DLARNV)
00045   (const int* const IDIST,
00046    int ISEED[],
00047    const int* const N,
00048    double X[]);
00049 
00050 extern "C" void F77_BLAS_MANGLE(dpotri, DPOTRI)
00051   (const char* const UPLO,
00052    const int* const N,
00053    double A[],
00054    const int* const LDA,
00055    int* const INFO);
00056 
00057 extern "C" void F77_BLAS_MANGLE(dpotrf, DPOTRF)
00058   (const char* const UPLO,
00059    const int* const N,
00060    double A[],
00061    const int* const LDA,
00062    int* const INFO);
00063 
00064 extern "C" void F77_BLAS_MANGLE(dpotrs, DPOTRS)
00065   (const char* const UPLO,
00066    const int* const N,
00067    const int* const NRHS,
00068    const double A[],
00069    const int* const LDA,
00070    double B[],
00071    const int* const LDB,
00072    int* const INFO);
00073 
00074 #ifdef HAVE_LAPACK_DLARFGP
00075 extern "C" void F77_BLAS_MANGLE(dlarfgp,DLARFGP)
00076   (const int* const N,    // IN
00077    double* const ALPHA,   // IN/OUT
00078    double X[],            // IN/OUT
00079    const int* const INCX, // IN
00080    double* const TAU);    // OUT
00081 #else
00082 #  ifdef HAVE_LAPACK_DLARFP
00083 extern "C" void F77_BLAS_MANGLE(dlarfp,DLARFP)
00084   (const int* const N,    // IN
00085    double* const ALPHA,   // IN/OUT
00086    double X[],            // IN/OUT
00087    const int* const INCX, // IN
00088    double* const TAU);    // OUT
00089 #  else
00090 extern "C" void F77_BLAS_MANGLE(dlarfg,DLARFG)
00091   (const int* const N,    // IN
00092    double* const ALPHA,   // IN/OUT
00093    double X[],            // IN/OUT
00094    const int* const INCX, // IN
00095    double* const TAU);    // OUT
00096 #  endif // HAVE_LAPACK_DLARFP
00097 #endif // HAVE_LAPACK_DLARFGP
00098 
00099 extern "C" void F77_BLAS_MANGLE(dgeqrf, DGEQRF)
00100   (const int* const M,
00101    const int* const N,
00102    double A[],
00103    const int* const LDA,
00104    double TAU[],
00105    double WORK[],
00106    const int* const LWORK,
00107    int* const INFO);
00108 
00109 #ifdef HAVE_LAPACK_DGEQRFP
00110 extern "C" void F77_BLAS_MANGLE(dgeqrfp, DGEQRFP)
00111   (const int* const M,
00112    const int* const N,
00113    double A[],
00114    const int* const LDA,
00115    double TAU[],
00116    double WORK[],
00117    const int* const LWORK,
00118    int* const INFO);
00119 #endif // HAVE_LAPACK_DGEQRFP
00120 
00121 extern "C" void F77_BLAS_MANGLE(dgeqr2, DGEQR2)
00122   (const int* const M,
00123    const int* const N,
00124    double A[],
00125    const int* const LDA,
00126    double TAU[],
00127    double WORK[],
00128    int* const INFO);
00129 
00130 #ifdef HAVE_LAPACK_DGEQR2P
00131 extern "C" void F77_BLAS_MANGLE(dgeqr2p, DGEQR2P)
00132   (const int* const M,
00133    const int* const N,
00134    double A[],
00135    const int* const LDA,
00136    double TAU[],
00137    double WORK[],
00138    int* const INFO);
00139 #endif // HAVE_LAPACK_DGEQR2P
00140 
00141 extern "C" void F77_BLAS_MANGLE(dormqr, DORMQR)
00142   (const char* const SIDE,
00143    const char* const TRANS,
00144    const int* const M,
00145    const int* const N,
00146    const int* const K,
00147    const double A[],
00148    const int* const LDA,
00149    const double TAU[],
00150    double C[],
00151    const int* const LDC,
00152    double WORK[],
00153    const int* const LWORK,
00154    int* const INFO);
00155 
00156 extern "C" void F77_BLAS_MANGLE(dorm2r, DORM2R)
00157   (const char* const SIDE,
00158    const char* const TRANS,
00159    const int* const M,
00160    const int* const N,
00161    const int* const K,
00162    const double A[],
00163    const int* const LDA,
00164    const double TAU[],
00165    double C[],
00166    const int* const LDC,
00167    double WORK[],
00168    int* const INFO);
00169 
00170 extern "C" void F77_BLAS_MANGLE(dorgqr, DORGQR)
00171   (const int* const M,
00172    const int* const N,
00173    const int* const K,
00174    double A[],
00175    const int* const LDA,
00176    double TAU[],
00177    double WORK[],
00178    const int* const LWORK,
00179    int* const INFO);
00180 
00181 extern "C" void F77_BLAS_MANGLE(dgesvd, DGESVD) 
00182   (const char* const JOBU, 
00183    const char* const JOBVT, 
00184    const int* const M, 
00185    const int* const N, 
00186    double A[], 
00187    const int* const LDA,
00188    double S[], 
00189    double U[], 
00190    const int* const LDU, 
00191    double VT[], 
00192    const int* const LDVT, 
00193    double work[],
00194    const int* const LWORK,
00195    double RWORK[],
00196    int* const INFO);
00197 
00200 
00201 namespace TSQR {
00202 
00203   // If _GEQRFP is available, LAPACK::GEQRF() calls it.  If _LARFP is
00204   // available, LAPACK::GEQRF() calls _GEQRF, which uses _LARFP.
00205 #ifdef HAVE_LAPACK_DGEQRFP
00206   template <>
00207   bool LAPACK<int, double >::QR_produces_R_factor_with_nonnegative_diagonal() { return true; }
00208 #else
00209 #  ifdef HAVE_LAPACK_DLARFP
00210   template <>
00211   bool LAPACK<int, double >::QR_produces_R_factor_with_nonnegative_diagonal() { return true; }
00212 #  else
00213   template <>
00214   bool LAPACK<int, double >::QR_produces_R_factor_with_nonnegative_diagonal() { return false; }
00215 #  endif
00216 #endif
00217 
00219   // LARFP (implemented with _LARFGP if available, else with _LARFP if
00220   // available, else fall back to _LARFG)
00222   template <>
00223   void 
00224   LAPACK<int, double >::LARFP (const int n, 
00225              double& alpha, 
00226              double x[], 
00227              const int incx, 
00228              double& tau)
00229   {
00230 #ifdef HAVE_LAPACK_DLARFGP
00231     F77_BLAS_MANGLE(dlarfgp,DLARFGP) (&n, &alpha, x, &incx, &tau);
00232 #else // Don't HAVE_LAPACK_DLARFGP
00233 #  ifdef HAVE_LAPACK_DLARFP
00234     F77_BLAS_MANGLE(dlarfp,DLARFP) (&n, &alpha, x, &incx, &tau);
00235 #  else
00236     F77_BLAS_MANGLE(dlarfg,DLARFG) (&n, &alpha, x, &incx, &tau);
00237 #  endif // HAVE_LAPACK_DLARFP
00238 #endif // HAVE_LAPACK_DLARFGP
00239   }
00240 
00242   // GEQRF (implemented with _GEQRFP if available, else fall back to _GEQRF)
00244   template <>
00245   void
00246   LAPACK<int, double >::GEQRF (const int m,
00247              const int n, 
00248              double A[],
00249              const int lda, 
00250              double tau[],
00251              double work[],
00252              const int lwork,
00253              int* const INFO)
00254   {
00255 #ifdef HAVE_LAPACK_DGEQRFP
00256     F77_BLAS_MANGLE(dgeqrfp, DGEQRFP) 
00257       (&m, &n, A, &lda, tau, work, &lwork, INFO);
00258 #else
00259     F77_BLAS_MANGLE(dgeqrf, DGEQRF) 
00260       (&m, &n, A, &lda, tau, work, &lwork, INFO);
00261 #endif // HAVE_LAPACK_DGEQRFP
00262   }
00263 
00265   // GEQR2 (implemented with _GEQR2P if available, else fall back to _GEQR2)
00267   template <>
00268   void
00269   LAPACK<int, double >::GEQR2 (const int m,
00270              const int n, 
00271              double A[],
00272              const int lda, 
00273              double tau[],
00274              double work[],
00275              int* const INFO)
00276   {
00277 #ifdef HAVE_LAPACK_DGEQR2P
00278     F77_BLAS_MANGLE(dgeqr2p, DGEQR2P) (&m, &n, A, &lda, tau, work, INFO);
00279 #else
00280     F77_BLAS_MANGLE(dgeqr2, DGEQR2) (&m, &n, A, &lda, tau, work, INFO);
00281 #endif // HAVE_LAPACK_DGEQR2P
00282   }
00283 
00284   template <>
00285   void
00286   LAPACK<int, double >::ORMQR (const char* const side,
00287              const char* const trans,
00288              const int m,
00289              const int n,
00290              const int k,
00291              const double A[],
00292              const int lda,
00293              const double tau[],
00294              double C[],
00295              const int ldc,
00296              double work[],
00297              const int lwork,
00298              int* const INFO)
00299   {
00300     F77_BLAS_MANGLE(dormqr, DORMQR) 
00301       (side, trans, &m, &n, &k, A, &lda, tau, C, &ldc, work, &lwork, INFO);
00302   }
00303 
00304   template <>
00305   void
00306   LAPACK<int, double >::ORM2R (const char* const side,
00307              const char* const trans,
00308              const int m,
00309              const int n,
00310              const int k,
00311              const double A[],
00312              const int lda,
00313              const double tau[],
00314              double C[],
00315              const int ldc,
00316              double work[],
00317              int* const INFO)
00318   {
00319     F77_BLAS_MANGLE(dorm2r, DORM2R) 
00320       (side, trans, &m, &n, &k, A, &lda, tau, C, &ldc, work, INFO);
00321   }
00322 
00323   template <>
00324   void
00325   LAPACK<int, double >::ORGQR (const int m,
00326              const int n,
00327              const int k,
00328              double A[],
00329              const int lda,
00330              double tau[],
00331              double work[],
00332              const int lwork,
00333              int* const INFO)
00334   {
00335     F77_BLAS_MANGLE(dorgqr, DORGQR) 
00336       (&m, &n, &k, A, &lda, tau, work, &lwork, INFO);
00337   }
00338 
00339   template <>
00340   void
00341   LAPACK<int, double >::POTRF (const char* const uplo,
00342              const int n,
00343              double A[],
00344              const int lda,
00345              int* const INFO)
00346   {
00347     F77_BLAS_MANGLE(dpotrf, DPOTRF) (uplo, &n, A, &lda, INFO);
00348   }
00349 
00350   template <>
00351   void
00352   LAPACK<int, double >::POTRS (const char* const uplo,
00353              const int n,
00354              const int nrhs,
00355              const double A[],
00356              const int lda,
00357              double B[],
00358              const int ldb,
00359              int* const INFO)
00360   {
00361     F77_BLAS_MANGLE(dpotrs, DPOTRS) 
00362       (uplo, &n, &nrhs, A, &lda, B, &ldb, INFO);
00363   }
00364 
00365   template <>
00366   void
00367   LAPACK<int, double >::POTRI (const char* const uplo, 
00368              const int n, 
00369              double A[], 
00370              const int lda, 
00371              int* const INFO)
00372   {
00373     F77_BLAS_MANGLE(dpotri, DPOTRI) (uplo, &n, A, &lda, INFO);
00374   }
00375 
00376   template <>
00377   void
00378   LAPACK<int, double >::LARNV (const int idist, 
00379              int iseed[],
00380              const int n,
00381              double x[])
00382   {
00383     F77_BLAS_MANGLE(dlarnv, DLARNV) (&idist, iseed, &n, x);
00384   }
00385 
00386   template <>
00387   void
00388   LAPACK<int, double >::GESVD (const char* const jobu,
00389              const char* const jobvt,
00390              const int m,
00391              const int n,
00392              double A[],
00393              const int lda,
00394              double s[],
00395              double U[],
00396              const int ldu,
00397              double VT[],
00398              const int ldvt,
00399              double work[],
00400              const int lwork,
00401              double rwork[],
00402              int* const INFO)
00403   {
00404     F77_BLAS_MANGLE(dgesvd, DGESVD) (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