Actual source code: svddense.c
1: /*
2: This file contains routines for handling small-size dense problems.
3: All routines are simply wrappers to LAPACK routines.
5: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6: SLEPc - Scalable Library for Eigenvalue Problem Computations
7: Copyright (c) 2002-2009, Universidad Politecnica de Valencia, Spain
9: This file is part of SLEPc.
10:
11: SLEPc is free software: you can redistribute it and/or modify it under the
12: terms of version 3 of the GNU Lesser General Public License as published by
13: the Free Software Foundation.
15: SLEPc is distributed in the hope that it will be useful, but WITHOUT ANY
16: WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
17: FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for
18: more details.
20: You should have received a copy of the GNU Lesser General Public License
21: along with SLEPc. If not, see <http://www.gnu.org/licenses/>.
22: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
23: */
25: #include private/svdimpl.h
26: #include slepcblaslapack.h
30: /*@
31: SVDDense - Solves a dense singular value problem.
33: Not Collective
35: Input Parameters:
36: + M - dimension of the problem (rows)
37: . N - dimension of the problem (colums)
38: - A - pointer to the array containing the matrix values
40: Output Parameters:
41: + sigma - pointer to the array to store the computed singular values
42: . U - pointer to the array to store left singular vectors
43: - VT - pointer to the array to store right singular vectors
45: Matrix A is overwritten.
46:
47: This routine uses LAPACK routines xGESDD.
49: Level: developer
51: @*/
52: PetscErrorCode SVDDense(PetscInt M_,PetscInt N_,PetscScalar* A,PetscReal* sigma,PetscScalar* U,PetscScalar* VT)
53: {
54: #if defined(SLEPC_MISSING_LAPACK_GESDD)
56: SETERRQ(PETSC_ERR_SUP,"GESDD - Lapack routine is unavailable.");
57: #else
59: PetscScalar qwork,*work;
60: PetscBLASInt n,info,lwork,*iwork,M,N;
61: #if defined(PETSC_USE_COMPLEX)
62: PetscReal *rwork;
63: #endif
64:
66: /* workspace query & allocation */
67: PetscLogEventBegin(SVD_Dense,0,0,0,0);
68: M = PetscBLASIntCast(M_);
69: N = PetscBLASIntCast(N_);
70: n = PetscMin(M,N);
71: PetscMalloc(sizeof(PetscInt)*8*n,&iwork);
72: lwork = -1;
73: #if defined(PETSC_USE_COMPLEX)
74: PetscMalloc(sizeof(PetscReal)*(5*n*n+7*n),&rwork);
75: LAPACKgesdd_("O",&M,&N,A,&M,sigma,U,&M,VT,&N,&qwork,&lwork,rwork,iwork,&info);
76: #else
77: LAPACKgesdd_("O",&M,&N,A,&M,sigma,U,&M,VT,&N,&qwork,&lwork,iwork,&info);
78: #endif
79: if (info) SETERRQ1(PETSC_ERR_LIB,"Error in Lapack xGESDD %d",info);
80: lwork = (PetscBLASInt)PetscRealPart(qwork);
81: PetscMalloc(sizeof(PetscScalar)*lwork,&work);
82:
83: /* computation */
84: #if defined(PETSC_USE_COMPLEX)
85: LAPACKgesdd_("O",&M,&N,A,&M,sigma,U,&M,VT,&N,work,&lwork,rwork,iwork,&info);
86: PetscFree(rwork);
87: #else
88: LAPACKgesdd_("O",&M,&N,A,&M,sigma,U,&M,VT,&N,work,&lwork,iwork,&info);
89: #endif
90: if (info) SETERRQ1(PETSC_ERR_LIB,"Error in Lapack xGESDD %d",info);
91: PetscFree(iwork);
92: PetscFree(work);
93: PetscLogEventEnd(SVD_Dense,0,0,0,0);
94: return(0);
95: #endif
96: }