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