Actual source code: svdscalap.c
slepc-3.15.0 2021-03-31
1: /*
2: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3: SLEPc - Scalable Library for Eigenvalue Problem Computations
4: Copyright (c) 2002-2021, Universitat Politecnica de Valencia, Spain
6: This file is part of SLEPc.
7: SLEPc is distributed under a 2-clause BSD license (see LICENSE).
8: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
9: */
10: /*
11: This file implements a wrapper to the ScaLAPACK SVD solver
12: */
14: #include <slepc/private/svdimpl.h>
15: #include <slepc/private/slepcscalapack.h>
17: typedef struct {
18: Mat As; /* converted matrix */
19: } SVD_ScaLAPACK;
21: PetscErrorCode SVDSetUp_ScaLAPACK(SVD svd)
22: {
24: SVD_ScaLAPACK *ctx = (SVD_ScaLAPACK*)svd->data;
25: PetscInt M,N;
28: SVDCheckStandard(svd);
29: MatGetSize(svd->A,&M,&N);
30: svd->ncv = N;
31: if (svd->mpd!=PETSC_DEFAULT) { PetscInfo(svd,"Warning: parameter mpd ignored\n"); }
32: if (svd->max_it==PETSC_DEFAULT) svd->max_it = 1;
33: svd->leftbasis = PETSC_TRUE;
34: SVDCheckUnsupported(svd,SVD_FEATURE_STOPPING);
35: SVDAllocateSolution(svd,0);
37: /* convert matrix */
38: MatDestroy(&ctx->As);
39: MatConvert(svd->OP,MATSCALAPACK,MAT_INITIAL_MATRIX,&ctx->As);
40: return(0);
41: }
43: PetscErrorCode SVDSolve_ScaLAPACK(SVD svd)
44: {
46: SVD_ScaLAPACK *ctx = (SVD_ScaLAPACK*)svd->data;
47: Mat A = ctx->As,Z,Q,QT,U,V;
48: Mat_ScaLAPACK *a = (Mat_ScaLAPACK*)A->data,*q,*z;
49: PetscScalar *work,minlwork;
50: PetscBLASInt info,lwork=-1,one=1;
51: PetscInt M,N,m,n,mn;
52: #if defined(PETSC_USE_COMPLEX)
53: PetscBLASInt lrwork;
54: PetscReal *rwork,dummy;
55: #endif
58: MatGetSize(A,&M,&N);
59: MatGetLocalSize(A,&m,&n);
60: mn = (M>=N)? n: m;
61: MatCreate(PetscObjectComm((PetscObject)A),&Z);
62: MatSetSizes(Z,m,mn,PETSC_DECIDE,PETSC_DECIDE);
63: MatSetType(Z,MATSCALAPACK);
64: MatSetUp(Z);
65: MatAssemblyBegin(Z,MAT_FINAL_ASSEMBLY);
66: MatAssemblyEnd(Z,MAT_FINAL_ASSEMBLY);
67: z = (Mat_ScaLAPACK*)Z->data;
68: MatCreate(PetscObjectComm((PetscObject)A),&QT);
69: MatSetSizes(QT,mn,n,PETSC_DECIDE,PETSC_DECIDE);
70: MatSetType(QT,MATSCALAPACK);
71: MatSetUp(QT);
72: MatAssemblyBegin(QT,MAT_FINAL_ASSEMBLY);
73: MatAssemblyEnd(QT,MAT_FINAL_ASSEMBLY);
74: q = (Mat_ScaLAPACK*)QT->data;
76: PetscFPTrapPush(PETSC_FP_TRAP_OFF);
77: #if !defined(PETSC_USE_COMPLEX)
78: /* allocate workspace */
79: PetscStackCallBLAS("SCALAPACKgesvd",SCALAPACKgesvd_("V","V",&a->M,&a->N,a->loc,&one,&one,a->desc,svd->sigma,z->loc,&one,&one,z->desc,q->loc,&one,&one,q->desc,&minlwork,&lwork,&info));
81: PetscBLASIntCast((PetscInt)minlwork,&lwork);
82: PetscMalloc1(lwork,&work);
83: /* call computational routine */
84: PetscStackCallBLAS("SCALAPACKgesvd",SCALAPACKgesvd_("V","V",&a->M,&a->N,a->loc,&one,&one,a->desc,svd->sigma,z->loc,&one,&one,z->desc,q->loc,&one,&one,q->desc,work,&lwork,&info));
86: PetscFree(work);
87: #else
88: /* allocate workspace */
89: PetscStackCallBLAS("SCALAPACKgesvd",SCALAPACKgesvd_("V","V",&a->M,&a->N,a->loc,&one,&one,a->desc,svd->sigma,z->loc,&one,&one,z->desc,q->loc,&one,&one,q->desc,&minlwork,&lwork,&dummy,&info));
91: PetscBLASIntCast((PetscInt)PetscRealPart(minlwork),&lwork);
92: lrwork = 1+4*PetscMax(a->M,a->N);
93: PetscMalloc2(lwork,&work,lrwork,&rwork);
94: /* call computational routine */
95: PetscStackCallBLAS("SCALAPACKgesvd",SCALAPACKgesvd_("V","V",&a->M,&a->N,a->loc,&one,&one,a->desc,svd->sigma,z->loc,&one,&one,z->desc,q->loc,&one,&one,q->desc,work,&lwork,rwork,&info));
97: PetscFree2(work,rwork);
98: #endif
99: PetscFPTrapPop();
101: MatHermitianTranspose(QT,MAT_INITIAL_MATRIX,&Q);
102: MatDestroy(&QT);
103: BVGetMat(svd->U,&U);
104: BVGetMat(svd->V,&V);
105: if (M>=N) {
106: MatConvert(Z,MATDENSE,MAT_REUSE_MATRIX,&U);
107: MatConvert(Q,MATDENSE,MAT_REUSE_MATRIX,&V);
108: } else {
109: MatConvert(Q,MATDENSE,MAT_REUSE_MATRIX,&U);
110: MatConvert(Z,MATDENSE,MAT_REUSE_MATRIX,&V);
111: }
112: BVRestoreMat(svd->U,&U);
113: BVRestoreMat(svd->V,&V);
114: MatDestroy(&Z);
115: MatDestroy(&Q);
117: svd->nconv = svd->ncv;
118: svd->its = 1;
119: svd->reason = SVD_CONVERGED_TOL;
120: return(0);
121: }
123: PetscErrorCode SVDDestroy_ScaLAPACK(SVD svd)
124: {
128: PetscFree(svd->data);
129: return(0);
130: }
132: PetscErrorCode SVDReset_ScaLAPACK(SVD svd)
133: {
135: SVD_ScaLAPACK *ctx = (SVD_ScaLAPACK*)svd->data;
138: MatDestroy(&ctx->As);
139: return(0);
140: }
142: SLEPC_EXTERN PetscErrorCode SVDCreate_ScaLAPACK(SVD svd)
143: {
145: SVD_ScaLAPACK *ctx;
148: PetscNewLog(svd,&ctx);
149: svd->data = (void*)ctx;
151: svd->ops->solve = SVDSolve_ScaLAPACK;
152: svd->ops->setup = SVDSetUp_ScaLAPACK;
153: svd->ops->destroy = SVDDestroy_ScaLAPACK;
154: svd->ops->reset = SVDReset_ScaLAPACK;
155: return(0);
156: }