Actual source code: dssvd.c
slepc-3.17.0 2022-03-31
1: /*
2: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3: SLEPc - Scalable Library for Eigenvalue Problem Computations
4: Copyright (c) 2002-, 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: */
11: #include <slepc/private/dsimpl.h>
12: #include <slepcblaslapack.h>
14: typedef struct {
15: PetscInt m; /* number of columns */
16: PetscInt t; /* number of rows of V after truncating */
17: } DS_SVD;
19: PetscErrorCode DSAllocate_SVD(DS ds,PetscInt ld)
20: {
21: DSAllocateMat_Private(ds,DS_MAT_A);
22: DSAllocateMat_Private(ds,DS_MAT_U);
23: DSAllocateMat_Private(ds,DS_MAT_V);
24: DSAllocateMatReal_Private(ds,DS_MAT_T);
25: PetscFree(ds->perm);
26: PetscMalloc1(ld,&ds->perm);
27: PetscLogObjectMemory((PetscObject)ds,ld*sizeof(PetscInt));
28: PetscFunctionReturn(0);
29: }
31: /* 0 l k n-1
32: -----------------------------------------
33: |* . . |
34: | * . . |
35: | * . . |
36: | * . . |
37: | o o |
38: | o o |
39: | o o |
40: | o o |
41: | o o |
42: | o o |
43: | o x |
44: | x x |
45: | x x |
46: | x x |
47: | x x |
48: | x x |
49: | x x |
50: | x x |
51: | x x|
52: | x|
53: -----------------------------------------
54: */
56: static PetscErrorCode DSSwitchFormat_SVD(DS ds)
57: {
58: DS_SVD *ctx = (DS_SVD*)ds->data;
59: PetscReal *T = ds->rmat[DS_MAT_T];
60: PetscScalar *A = ds->mat[DS_MAT_A];
61: PetscInt i,m=ctx->m,k=ds->k,ld=ds->ld;
64: /* switch from compact (arrow) to dense storage */
65: PetscArrayzero(A,ld*ld);
66: for (i=0;i<k;i++) {
67: A[i+i*ld] = T[i];
68: A[i+k*ld] = T[i+ld];
69: }
70: A[k+k*ld] = T[k];
71: for (i=k+1;i<m;i++) {
72: A[i+i*ld] = T[i];
73: A[i-1+i*ld] = T[i-1+ld];
74: }
75: PetscFunctionReturn(0);
76: }
78: PetscErrorCode DSView_SVD(DS ds,PetscViewer viewer)
79: {
80: DS_SVD *ctx = (DS_SVD*)ds->data;
81: PetscViewerFormat format;
82: PetscInt i,j,r,c,m=ctx->m,rows,cols;
83: PetscReal value;
85: PetscViewerGetFormat(viewer,&format);
86: if (format == PETSC_VIEWER_ASCII_INFO) PetscFunctionReturn(0);
87: if (format == PETSC_VIEWER_ASCII_INFO_DETAIL) {
88: PetscViewerASCIIPrintf(viewer,"number of columns: %" PetscInt_FMT "\n",m);
89: PetscFunctionReturn(0);
90: }
92: if (ds->compact) {
93: PetscViewerASCIIUseTabs(viewer,PETSC_FALSE);
94: rows = ds->n;
95: cols = ds->extrarow? m+1: m;
96: if (format == PETSC_VIEWER_ASCII_MATLAB) {
97: PetscViewerASCIIPrintf(viewer,"%% Size = %" PetscInt_FMT " %" PetscInt_FMT "\n",rows,cols);
98: PetscViewerASCIIPrintf(viewer,"zzz = zeros(%" PetscInt_FMT ",3);\n",2*ds->n);
99: PetscViewerASCIIPrintf(viewer,"zzz = [\n");
100: for (i=0;i<PetscMin(ds->n,m);i++) PetscViewerASCIIPrintf(viewer,"%" PetscInt_FMT " %" PetscInt_FMT " %18.16e\n",i+1,i+1,(double)*(ds->rmat[DS_MAT_T]+i));
101: for (i=0;i<cols-1;i++) {
102: r = PetscMax(i+2,ds->k+1);
103: c = i+1;
104: PetscViewerASCIIPrintf(viewer,"%" PetscInt_FMT " %" PetscInt_FMT " %18.16e\n",c,r,(double)*(ds->rmat[DS_MAT_T]+ds->ld+i));
105: }
106: PetscViewerASCIIPrintf(viewer,"];\n%s = spconvert(zzz);\n",DSMatName[DS_MAT_T]);
107: } else {
108: for (i=0;i<rows;i++) {
109: for (j=0;j<cols;j++) {
110: if (i==j) value = *(ds->rmat[DS_MAT_T]+i);
111: else if (i<ds->k && j==ds->k) value = *(ds->rmat[DS_MAT_T]+ds->ld+PetscMin(i,j));
112: else if (i+1==j && i>=ds->k) value = *(ds->rmat[DS_MAT_T]+ds->ld+i);
113: else value = 0.0;
114: PetscViewerASCIIPrintf(viewer," %18.16e ",(double)value);
115: }
116: PetscViewerASCIIPrintf(viewer,"\n");
117: }
118: }
119: PetscViewerASCIIUseTabs(viewer,PETSC_TRUE);
120: PetscViewerFlush(viewer);
121: } else DSViewMat(ds,viewer,DS_MAT_A);
122: if (ds->state>DS_STATE_INTERMEDIATE) {
123: DSViewMat(ds,viewer,DS_MAT_U);
124: DSViewMat(ds,viewer,DS_MAT_V);
125: }
126: PetscFunctionReturn(0);
127: }
129: PetscErrorCode DSVectors_SVD(DS ds,DSMatType mat,PetscInt *j,PetscReal *rnorm)
130: {
131: switch (mat) {
132: case DS_MAT_U:
133: case DS_MAT_V:
134: if (rnorm) *rnorm = 0.0;
135: break;
136: default:
137: SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid mat parameter");
138: }
139: PetscFunctionReturn(0);
140: }
142: PetscErrorCode DSSort_SVD(DS ds,PetscScalar *wr,PetscScalar *wi,PetscScalar *rr,PetscScalar *ri,PetscInt *k)
143: {
144: DS_SVD *ctx = (DS_SVD*)ds->data;
145: PetscInt n,l,i,*perm,ld=ds->ld;
146: PetscScalar *A;
147: PetscReal *d;
149: if (!ds->sc) PetscFunctionReturn(0);
151: l = ds->l;
152: n = PetscMin(ds->n,ctx->m);
153: A = ds->mat[DS_MAT_A];
154: d = ds->rmat[DS_MAT_T];
155: perm = ds->perm;
156: if (!rr) DSSortEigenvaluesReal_Private(ds,d,perm);
157: else DSSortEigenvalues_Private(ds,rr,ri,perm,PETSC_FALSE);
158: for (i=l;i<n;i++) wr[i] = d[perm[i]];
159: DSPermuteBoth_Private(ds,l,n,ds->n,ctx->m,DS_MAT_U,DS_MAT_V,perm);
160: for (i=l;i<n;i++) d[i] = PetscRealPart(wr[i]);
161: if (!ds->compact) {
162: for (i=l;i<n;i++) A[i+i*ld] = wr[i];
163: }
164: PetscFunctionReturn(0);
165: }
167: PetscErrorCode DSUpdateExtraRow_SVD(DS ds)
168: {
169: DS_SVD *ctx = (DS_SVD*)ds->data;
170: PetscInt i;
171: PetscBLASInt n=0,m=0,ld,incx=1;
172: PetscScalar *A,*U,*x,*y,one=1.0,zero=0.0;
173: PetscReal *e,beta;
176: PetscBLASIntCast(ds->n,&n);
177: PetscBLASIntCast(ctx->m,&m);
178: PetscBLASIntCast(ds->ld,&ld);
179: A = ds->mat[DS_MAT_A];
180: U = ds->mat[DS_MAT_U];
181: e = ds->rmat[DS_MAT_T]+ld;
183: if (ds->compact) {
184: beta = e[m-1]; /* in compact, we assume all entries are zero except the last one */
185: for (i=0;i<n;i++) e[i] = PetscRealPart(beta*U[n-1+i*ld]);
186: ds->k = m;
187: } else {
188: DSAllocateWork_Private(ds,2*ld,0,0);
189: x = ds->work;
190: y = ds->work+ld;
191: for (i=0;i<n;i++) x[i] = PetscConj(A[i+m*ld]);
192: PetscStackCallBLAS("BLASgemv",BLASgemv_("C",&n,&n,&one,U,&ld,x,&incx,&zero,y,&incx));
193: for (i=0;i<n;i++) A[i+m*ld] = PetscConj(y[i]);
194: ds->k = m;
195: }
196: PetscFunctionReturn(0);
197: }
199: PetscErrorCode DSTruncate_SVD(DS ds,PetscInt n,PetscBool trim)
200: {
201: PetscInt i,ld=ds->ld,l=ds->l;
202: PetscScalar *A = ds->mat[DS_MAT_A];
203: DS_SVD *ctx = (DS_SVD*)ds->data;
205: if (trim) {
206: if (!ds->compact && ds->extrarow) { /* clean extra column */
207: for (i=l;i<ds->n;i++) A[i+ctx->m*ld] = 0.0;
208: }
209: ds->l = 0;
210: ds->k = 0;
211: ds->n = n;
212: ctx->m = n;
213: ds->t = ds->n; /* truncated length equal to the new dimension */
214: ctx->t = ctx->m; /* must also keep the previous dimension of V */
215: } else {
216: if (!ds->compact && ds->extrarow && ds->k==ds->n) {
217: /* copy entries of extra column to the new position, then clean last row */
218: for (i=l;i<n;i++) A[i+n*ld] = A[i+ctx->m*ld];
219: for (i=l;i<ds->n;i++) A[i+ctx->m*ld] = 0.0;
220: }
221: ds->k = (ds->extrarow)? n: 0;
222: ds->t = ds->n; /* truncated length equal to previous dimension */
223: ctx->t = ctx->m; /* must also keep the previous dimension of V */
224: ds->n = n;
225: ctx->m = n;
226: }
227: PetscFunctionReturn(0);
228: }
230: PetscErrorCode DSSolve_SVD_DC(DS ds,PetscScalar *wr,PetscScalar *wi)
231: {
232: DS_SVD *ctx = (DS_SVD*)ds->data;
233: PetscInt i,j;
234: PetscBLASInt n1,m1,info,l = 0,n = 0,m = 0,nm,ld,off,lwork;
235: PetscScalar *A,*U,*V,*W,qwork;
236: PetscReal *d,*e,*Ur,*Vr;
239: PetscBLASIntCast(ds->n,&n);
240: PetscBLASIntCast(ctx->m,&m);
241: PetscBLASIntCast(ds->l,&l);
242: PetscBLASIntCast(ds->ld,&ld);
243: n1 = n-l; /* n1 = size of leading block, excl. locked + size of trailing block */
244: m1 = m-l;
245: off = l+l*ld;
246: A = ds->mat[DS_MAT_A];
247: U = ds->mat[DS_MAT_U];
248: V = ds->mat[DS_MAT_V];
249: d = ds->rmat[DS_MAT_T];
250: e = ds->rmat[DS_MAT_T]+ld;
251: PetscArrayzero(U,ld*ld);
252: for (i=0;i<l;i++) U[i+i*ld] = 1.0;
253: PetscArrayzero(V,ld*ld);
254: for (i=0;i<l;i++) V[i+i*ld] = 1.0;
256: if (ds->state>DS_STATE_RAW) {
257: /* solve bidiagonal SVD problem */
258: for (i=0;i<l;i++) wr[i] = d[i];
259: #if defined(PETSC_USE_COMPLEX)
260: DSAllocateWork_Private(ds,0,3*n1*n1+4*n1,8*n1);
261: DSAllocateMatReal_Private(ds,DS_MAT_U);
262: DSAllocateMatReal_Private(ds,DS_MAT_V);
263: Ur = ds->rmat[DS_MAT_U];
264: Vr = ds->rmat[DS_MAT_V];
265: #else
266: DSAllocateWork_Private(ds,0,3*n1*n1+4*n1+ld*ld,8*n1);
267: Ur = U;
268: Vr = ds->rwork+3*n1*n1+4*n1;
269: #endif
270: PetscStackCallBLAS("LAPACKbdsdc",LAPACKbdsdc_("U","I",&n1,d+l,e+l,Ur+off,&ld,Vr+off,&ld,NULL,NULL,ds->rwork,ds->iwork,&info));
271: SlepcCheckLapackInfo("bdsdc",info);
272: for (i=l;i<n;i++) {
273: for (j=l;j<n;j++) {
274: #if defined(PETSC_USE_COMPLEX)
275: U[i+j*ld] = Ur[i+j*ld];
276: #endif
277: V[i+j*ld] = PetscConj(Vr[j+i*ld]); /* transpose VT returned by Lapack */
278: }
279: }
280: } else {
281: /* solve general rectangular SVD problem */
282: DSAllocateMat_Private(ds,DS_MAT_W);
283: W = ds->mat[DS_MAT_W];
284: if (ds->compact) DSSwitchFormat_SVD(ds);
285: for (i=0;i<l;i++) wr[i] = d[i];
286: nm = PetscMin(n,m);
287: DSAllocateWork_Private(ds,0,0,8*nm);
288: lwork = -1;
289: #if defined(PETSC_USE_COMPLEX)
290: DSAllocateWork_Private(ds,0,5*nm*nm+7*nm,0);
291: PetscStackCallBLAS("LAPACKgesdd",LAPACKgesdd_("A",&n1,&m1,A+off,&ld,d+l,U+off,&ld,W+off,&ld,&qwork,&lwork,ds->rwork,ds->iwork,&info));
292: #else
293: PetscStackCallBLAS("LAPACKgesdd",LAPACKgesdd_("A",&n1,&m1,A+off,&ld,d+l,U+off,&ld,W+off,&ld,&qwork,&lwork,ds->iwork,&info));
294: #endif
295: SlepcCheckLapackInfo("gesdd",info);
296: PetscBLASIntCast((PetscInt)PetscRealPart(qwork),&lwork);
297: DSAllocateWork_Private(ds,lwork,0,0);
298: #if defined(PETSC_USE_COMPLEX)
299: PetscStackCallBLAS("LAPACKgesdd",LAPACKgesdd_("A",&n1,&m1,A+off,&ld,d+l,U+off,&ld,W+off,&ld,ds->work,&lwork,ds->rwork,ds->iwork,&info));
300: #else
301: PetscStackCallBLAS("LAPACKgesdd",LAPACKgesdd_("A",&n1,&m1,A+off,&ld,d+l,U+off,&ld,W+off,&ld,ds->work,&lwork,ds->iwork,&info));
302: #endif
303: SlepcCheckLapackInfo("gesdd",info);
304: for (i=l;i<m;i++) {
305: for (j=l;j<m;j++) V[i+j*ld] = PetscConj(W[j+i*ld]); /* transpose VT returned by Lapack */
306: }
307: }
308: for (i=l;i<PetscMin(ds->n,ctx->m);i++) wr[i] = d[i];
310: /* create diagonal matrix as a result */
311: if (ds->compact) PetscArrayzero(e,n-1);
312: else {
313: for (i=l;i<m;i++) PetscArrayzero(A+l+i*ld,n-l);
314: for (i=l;i<n;i++) A[i+i*ld] = d[i];
315: }
316: PetscFunctionReturn(0);
317: }
319: PetscErrorCode DSSynchronize_SVD(DS ds,PetscScalar eigr[],PetscScalar eigi[])
320: {
321: PetscInt ld=ds->ld,l=ds->l,k=0,kr=0;
322: PetscMPIInt n,rank,off=0,size,ldn,ld3;
324: if (ds->compact) kr = 3*ld;
325: else k = (ds->n-l)*ld;
326: if (ds->state>DS_STATE_RAW) k += 2*(ds->n-l)*ld;
327: if (eigr) k += ds->n-l;
328: DSAllocateWork_Private(ds,k+kr,0,0);
329: PetscMPIIntCast(k*sizeof(PetscScalar)+kr*sizeof(PetscReal),&size);
330: PetscMPIIntCast(ds->n-l,&n);
331: PetscMPIIntCast(ld*(ds->n-l),&ldn);
332: PetscMPIIntCast(3*ld,&ld3);
333: MPI_Comm_rank(PetscObjectComm((PetscObject)ds),&rank);
334: if (!rank) {
335: if (ds->compact) MPI_Pack(ds->rmat[DS_MAT_T],ld3,MPIU_REAL,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
336: else MPI_Pack(ds->mat[DS_MAT_A]+l*ld,ldn,MPIU_SCALAR,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
337: if (ds->state>DS_STATE_RAW) {
338: MPI_Pack(ds->mat[DS_MAT_U]+l*ld,ldn,MPIU_SCALAR,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
339: MPI_Pack(ds->mat[DS_MAT_V]+l*ld,ldn,MPIU_SCALAR,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
340: }
341: if (eigr) MPI_Pack(eigr+l,n,MPIU_SCALAR,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
342: }
343: MPI_Bcast(ds->work,size,MPI_BYTE,0,PetscObjectComm((PetscObject)ds));
344: if (rank) {
345: if (ds->compact) MPI_Unpack(ds->work,size,&off,ds->rmat[DS_MAT_T],ld3,MPIU_REAL,PetscObjectComm((PetscObject)ds));
346: else MPI_Unpack(ds->work,size,&off,ds->mat[DS_MAT_A]+l*ld,ldn,MPIU_SCALAR,PetscObjectComm((PetscObject)ds));
347: if (ds->state>DS_STATE_RAW) {
348: MPI_Unpack(ds->work,size,&off,ds->mat[DS_MAT_U]+l*ld,ldn,MPIU_SCALAR,PetscObjectComm((PetscObject)ds));
349: MPI_Unpack(ds->work,size,&off,ds->mat[DS_MAT_V]+l*ld,ldn,MPIU_SCALAR,PetscObjectComm((PetscObject)ds));
350: }
351: if (eigr) MPI_Unpack(ds->work,size,&off,eigr+l,n,MPIU_SCALAR,PetscObjectComm((PetscObject)ds));
352: }
353: PetscFunctionReturn(0);
354: }
356: PetscErrorCode DSMatGetSize_SVD(DS ds,DSMatType t,PetscInt *rows,PetscInt *cols)
357: {
358: DS_SVD *ctx = (DS_SVD*)ds->data;
361: switch (t) {
362: case DS_MAT_A:
363: case DS_MAT_T:
364: *rows = ds->n;
365: *cols = ds->extrarow? ctx->m+1: ctx->m;
366: break;
367: case DS_MAT_U:
368: *rows = ds->state==DS_STATE_TRUNCATED? ds->t: ds->n;
369: *cols = ds->n;
370: break;
371: case DS_MAT_V:
372: *rows = ds->state==DS_STATE_TRUNCATED? ctx->t: ctx->m;
373: *cols = ctx->m;
374: break;
375: default:
376: SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid t parameter");
377: }
378: PetscFunctionReturn(0);
379: }
381: static PetscErrorCode DSSVDSetDimensions_SVD(DS ds,PetscInt m)
382: {
383: DS_SVD *ctx = (DS_SVD*)ds->data;
385: DSCheckAlloc(ds,1);
386: if (m==PETSC_DECIDE || m==PETSC_DEFAULT) {
387: ctx->m = ds->ld;
388: } else {
390: ctx->m = m;
391: }
392: PetscFunctionReturn(0);
393: }
395: /*@
396: DSSVDSetDimensions - Sets the number of columns for a DSSVD.
398: Logically Collective on ds
400: Input Parameters:
401: + ds - the direct solver context
402: - m - the number of columns
404: Notes:
405: This call is complementary to DSSetDimensions(), to provide a dimension
406: that is specific to this DS type.
408: Level: intermediate
410: .seealso: DSSVDGetDimensions(), DSSetDimensions()
411: @*/
412: PetscErrorCode DSSVDSetDimensions(DS ds,PetscInt m)
413: {
416: PetscTryMethod(ds,"DSSVDSetDimensions_C",(DS,PetscInt),(ds,m));
417: PetscFunctionReturn(0);
418: }
420: static PetscErrorCode DSSVDGetDimensions_SVD(DS ds,PetscInt *m)
421: {
422: DS_SVD *ctx = (DS_SVD*)ds->data;
424: *m = ctx->m;
425: PetscFunctionReturn(0);
426: }
428: /*@
429: DSSVDGetDimensions - Returns the number of columns for a DSSVD.
431: Not collective
433: Input Parameter:
434: . ds - the direct solver context
436: Output Parameters:
437: . m - the number of columns
439: Level: intermediate
441: .seealso: DSSVDSetDimensions()
442: @*/
443: PetscErrorCode DSSVDGetDimensions(DS ds,PetscInt *m)
444: {
447: PetscUseMethod(ds,"DSSVDGetDimensions_C",(DS,PetscInt*),(ds,m));
448: PetscFunctionReturn(0);
449: }
451: PetscErrorCode DSDestroy_SVD(DS ds)
452: {
453: PetscFree(ds->data);
454: PetscObjectComposeFunction((PetscObject)ds,"DSSVDSetDimensions_C",NULL);
455: PetscObjectComposeFunction((PetscObject)ds,"DSSVDGetDimensions_C",NULL);
456: PetscFunctionReturn(0);
457: }
459: /*MC
460: DSSVD - Dense Singular Value Decomposition.
462: Level: beginner
464: Notes:
465: The problem is expressed as A = U*Sigma*V', where A is rectangular in
466: general, with n rows and m columns. Sigma is a diagonal matrix whose diagonal
467: elements are the arguments of DSSolve(). After solve, A is overwritten
468: with Sigma.
470: The orthogonal (or unitary) matrices of left and right singular vectors, U
471: and V, have size n and m, respectively. The number of columns m must
472: be specified via DSSVDSetDimensions().
474: If the DS object is in the intermediate state, A is assumed to be in upper
475: bidiagonal form (possibly with an arrow) and is stored in compact format
476: on matrix T. Otherwise, no particular structure is assumed. The compact
477: storage is implemented for the square case only, m=n. The extra row should
478: be interpreted in this case as an extra column.
480: Used DS matrices:
481: + DS_MAT_A - problem matrix
482: - DS_MAT_T - upper bidiagonal matrix
484: Implemented methods:
485: . 0 - Divide and Conquer (_bdsdc or _gesdd)
487: .seealso: DSCreate(), DSSetType(), DSType, DSSVDSetDimensions()
488: M*/
489: SLEPC_EXTERN PetscErrorCode DSCreate_SVD(DS ds)
490: {
491: DS_SVD *ctx;
493: PetscNewLog(ds,&ctx);
494: ds->data = (void*)ctx;
496: ds->ops->allocate = DSAllocate_SVD;
497: ds->ops->view = DSView_SVD;
498: ds->ops->vectors = DSVectors_SVD;
499: ds->ops->solve[0] = DSSolve_SVD_DC;
500: ds->ops->sort = DSSort_SVD;
501: ds->ops->synchronize = DSSynchronize_SVD;
502: ds->ops->truncate = DSTruncate_SVD;
503: ds->ops->update = DSUpdateExtraRow_SVD;
504: ds->ops->destroy = DSDestroy_SVD;
505: ds->ops->matgetsize = DSMatGetSize_SVD;
506: PetscObjectComposeFunction((PetscObject)ds,"DSSVDSetDimensions_C",DSSVDSetDimensions_SVD);
507: PetscObjectComposeFunction((PetscObject)ds,"DSSVDGetDimensions_C",DSSVDGetDimensions_SVD);
508: PetscFunctionReturn(0);
509: }