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