Actual source code: dspriv.c
slepc-3.18.1 2022-11-02
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: */
10: /*
11: Private DS routines
12: */
14: #include <slepc/private/dsimpl.h>
15: #include <slepcblaslapack.h>
17: PetscErrorCode DSAllocateMat_Private(DS ds,DSMatType m)
18: {
19: PetscInt n,d,rows=0,cols;
20: PetscBool ispep,isnep;
22: n = ds->ld;
23: PetscObjectTypeCompare((PetscObject)ds,DSPEP,&ispep);
24: if (ispep) {
25: if (m==DS_MAT_A || m==DS_MAT_B || m==DS_MAT_W || m==DS_MAT_U || m==DS_MAT_X || m==DS_MAT_Y) {
26: DSPEPGetDegree(ds,&d);
27: n = d*ds->ld;
28: }
29: } else {
30: PetscObjectTypeCompare((PetscObject)ds,DSNEP,&isnep);
31: if (isnep) {
32: if (m==DS_MAT_Q || m==DS_MAT_Z || m==DS_MAT_U || m==DS_MAT_V || m==DS_MAT_X || m==DS_MAT_Y) {
33: DSNEPGetMinimality(ds,&d);
34: n = d*ds->ld;
35: }
36: }
37: }
38: cols = n;
40: switch (m) {
41: case DS_MAT_T:
42: cols = PetscDefined(USE_COMPLEX)? 2: 3;
43: rows = n;
44: break;
45: case DS_MAT_D:
46: cols = 1;
47: rows = n;
48: break;
49: case DS_MAT_X:
50: rows = ds->ld;
51: break;
52: case DS_MAT_Y:
53: rows = ds->ld;
54: break;
55: default:
56: rows = n;
57: }
58: if (ds->omat[m]) MatZeroEntries(ds->omat[m]);
59: else {
60: MatCreateSeqDense(PETSC_COMM_SELF,rows,cols,NULL,&ds->omat[m]);
61: }
62: return 0;
63: }
65: PetscErrorCode DSAllocateWork_Private(DS ds,PetscInt s,PetscInt r,PetscInt i)
66: {
67: if (s>ds->lwork) {
68: PetscFree(ds->work);
69: PetscMalloc1(s,&ds->work);
70: ds->lwork = s;
71: }
72: if (r>ds->lrwork) {
73: PetscFree(ds->rwork);
74: PetscMalloc1(r,&ds->rwork);
75: ds->lrwork = r;
76: }
77: if (i>ds->liwork) {
78: PetscFree(ds->iwork);
79: PetscMalloc1(i,&ds->iwork);
80: ds->liwork = i;
81: }
82: return 0;
83: }
85: /*@C
86: DSViewMat - Prints one of the internal DS matrices.
88: Collective on ds
90: Input Parameters:
91: + ds - the direct solver context
92: . viewer - visualization context
93: - m - matrix to display
95: Note:
96: Works only for ascii viewers. Set the viewer in Matlab format if
97: want to paste into Matlab.
99: Level: developer
101: .seealso: DSView()
102: @*/
103: PetscErrorCode DSViewMat(DS ds,PetscViewer viewer,DSMatType m)
104: {
105: PetscInt i,j,rows,cols;
106: const PetscScalar *M=NULL,*v;
107: PetscViewerFormat format;
108: #if defined(PETSC_USE_COMPLEX)
109: PetscBool allreal = PETSC_TRUE;
110: const PetscReal *vr;
111: #endif
115: DSCheckValidMat(ds,m,3);
116: if (!viewer) PetscViewerASCIIGetStdout(PetscObjectComm((PetscObject)ds),&viewer);
119: PetscViewerGetFormat(viewer,&format);
120: if (format == PETSC_VIEWER_ASCII_INFO || format == PETSC_VIEWER_ASCII_INFO_DETAIL) return 0;
121: PetscViewerASCIIUseTabs(viewer,PETSC_FALSE);
122: DSMatGetSize(ds,m,&rows,&cols);
123: MatDenseGetArrayRead(ds->omat[m],&M);
124: #if defined(PETSC_USE_COMPLEX)
125: /* determine if matrix has all real values */
126: if (m!=DS_MAT_T && m!=DS_MAT_D) {
127: /* determine if matrix has all real values */
128: v = M;
129: for (i=0;i<rows;i++)
130: for (j=0;j<cols;j++)
131: if (PetscImaginaryPart(v[i+j*ds->ld])) { allreal = PETSC_FALSE; break; }
132: }
133: if (m==DS_MAT_T) cols=3;
134: #endif
135: if (format == PETSC_VIEWER_ASCII_MATLAB) {
136: PetscViewerASCIIPrintf(viewer,"%% Size = %" PetscInt_FMT " %" PetscInt_FMT "\n",rows,cols);
137: PetscViewerASCIIPrintf(viewer,"%s = [\n",DSMatName[m]);
138: } else PetscViewerASCIIPrintf(viewer,"Matrix %s =\n",DSMatName[m]);
140: for (i=0;i<rows;i++) {
141: v = M+i;
142: #if defined(PETSC_USE_COMPLEX)
143: vr = (const PetscReal*)M+i; /* handle compact storage, 2nd column is in imaginary part of 1st column */
144: #endif
145: for (j=0;j<cols;j++) {
146: #if defined(PETSC_USE_COMPLEX)
147: if (m!=DS_MAT_T && m!=DS_MAT_D) {
148: if (allreal) PetscViewerASCIIPrintf(viewer,"%18.16e ",(double)PetscRealPart(*v));
149: else PetscViewerASCIIPrintf(viewer,"%18.16e%+18.16ei ",(double)PetscRealPart(*v),(double)PetscImaginaryPart(*v));
150: } else PetscViewerASCIIPrintf(viewer,"%18.16e ",(double)*vr);
151: #else
152: PetscViewerASCIIPrintf(viewer,"%18.16e ",(double)*v);
153: #endif
154: v += ds->ld;
155: #if defined(PETSC_USE_COMPLEX)
156: if (m==DS_MAT_T) vr += ds->ld;
157: #endif
158: }
159: PetscViewerASCIIPrintf(viewer,"\n");
160: }
161: MatDenseRestoreArrayRead(ds->omat[m],&M);
163: if (format == PETSC_VIEWER_ASCII_MATLAB) PetscViewerASCIIPrintf(viewer,"];\n");
164: PetscViewerASCIIUseTabs(viewer,PETSC_TRUE);
165: PetscViewerFlush(viewer);
166: return 0;
167: }
169: PetscErrorCode DSSortEigenvalues_Private(DS ds,PetscScalar *wr,PetscScalar *wi,PetscInt *perm,PetscBool isghiep)
170: {
171: PetscScalar re,im,wi0;
172: PetscInt n,i,j,result,tmp1,tmp2=0,d=1;
174: n = ds->t; /* sort only first t pairs if truncated */
175: /* insertion sort */
176: i=ds->l+1;
177: #if !defined(PETSC_USE_COMPLEX)
178: if (wi && wi[perm[i-1]]!=0.0) i++; /* initial value is complex */
179: #else
180: if (isghiep && PetscImaginaryPart(wr[perm[i-1]])!=0.0) i++;
181: #endif
182: for (;i<n;i+=d) {
183: re = wr[perm[i]];
184: if (wi) im = wi[perm[i]];
185: else im = 0.0;
186: tmp1 = perm[i];
187: #if !defined(PETSC_USE_COMPLEX)
188: if (im!=0.0) { d = 2; tmp2 = perm[i+1]; }
189: else d = 1;
190: #else
191: if (isghiep && PetscImaginaryPart(re)!=0.0) { d = 2; tmp2 = perm[i+1]; }
192: else d = 1;
193: #endif
194: j = i-1;
195: if (wi) wi0 = wi[perm[j]];
196: else wi0 = 0.0;
197: SlepcSCCompare(ds->sc,re,im,wr[perm[j]],wi0,&result);
198: while (result<0 && j>=ds->l) {
199: perm[j+d] = perm[j];
200: j--;
201: #if !defined(PETSC_USE_COMPLEX)
202: if (wi && wi[perm[j+1]]!=0)
203: #else
204: if (isghiep && PetscImaginaryPart(wr[perm[j+1]])!=0)
205: #endif
206: { perm[j+d] = perm[j]; j--; }
208: if (j>=ds->l) {
209: if (wi) wi0 = wi[perm[j]];
210: else wi0 = 0.0;
211: SlepcSCCompare(ds->sc,re,im,wr[perm[j]],wi0,&result);
212: }
213: }
214: perm[j+1] = tmp1;
215: if (d==2) perm[j+2] = tmp2;
216: }
217: return 0;
218: }
220: PetscErrorCode DSSortEigenvaluesReal_Private(DS ds,PetscReal *eig,PetscInt *perm)
221: {
222: PetscScalar re;
223: PetscInt i,j,result,tmp,l,n;
225: n = ds->t; /* sort only first t pairs if truncated */
226: l = ds->l;
227: /* insertion sort */
228: for (i=l+1;i<n;i++) {
229: re = eig[perm[i]];
230: j = i-1;
231: SlepcSCCompare(ds->sc,re,0.0,eig[perm[j]],0.0,&result);
232: while (result<0 && j>=l) {
233: tmp = perm[j]; perm[j] = perm[j+1]; perm[j+1] = tmp; j--;
234: if (j>=l) SlepcSCCompare(ds->sc,re,0.0,eig[perm[j]],0.0,&result);
235: }
236: }
237: return 0;
238: }
240: /*
241: Permute comumns [istart..iend-1] of [mat] according to perm. Columns have length n
242: */
243: PetscErrorCode DSPermuteColumns_Private(DS ds,PetscInt istart,PetscInt iend,PetscInt n,DSMatType mat,PetscInt *perm)
244: {
245: PetscInt i,j,k,p,ld;
246: PetscScalar *Q,rtmp;
248: ld = ds->ld;
249: MatDenseGetArray(ds->omat[mat],&Q);
250: for (i=istart;i<iend;i++) {
251: p = perm[i];
252: if (p != i) {
253: j = i + 1;
254: while (perm[j] != i) j++;
255: perm[j] = p; perm[i] = i;
256: /* swap columns i and j */
257: for (k=0;k<n;k++) {
258: rtmp = Q[k+p*ld]; Q[k+p*ld] = Q[k+i*ld]; Q[k+i*ld] = rtmp;
259: }
260: }
261: }
262: MatDenseRestoreArray(ds->omat[mat],&Q);
263: return 0;
264: }
266: /*
267: The same as DSPermuteColumns_Private but for two matrices [mat1] and [mat2]
268: */
269: PetscErrorCode DSPermuteColumnsTwo_Private(DS ds,PetscInt istart,PetscInt iend,PetscInt n,DSMatType mat1,DSMatType mat2,PetscInt *perm)
270: {
271: PetscInt i,j,k,p,ld;
272: PetscScalar *Q,*Z,rtmp,rtmp2;
274: ld = ds->ld;
275: MatDenseGetArray(ds->omat[mat1],&Q);
276: MatDenseGetArray(ds->omat[mat2],&Z);
277: for (i=istart;i<iend;i++) {
278: p = perm[i];
279: if (p != i) {
280: j = i + 1;
281: while (perm[j] != i) j++;
282: perm[j] = p; perm[i] = i;
283: /* swap columns i and j */
284: for (k=0;k<n;k++) {
285: rtmp = Q[k+p*ld]; Q[k+p*ld] = Q[k+i*ld]; Q[k+i*ld] = rtmp;
286: rtmp2 = Z[k+p*ld]; Z[k+p*ld] = Z[k+i*ld]; Z[k+i*ld] = rtmp2;
287: }
288: }
289: }
290: MatDenseRestoreArray(ds->omat[mat1],&Q);
291: MatDenseRestoreArray(ds->omat[mat2],&Z);
292: return 0;
293: }
295: /*
296: Permute rows [istart..iend-1] of [mat] according to perm. Rows have length m
297: */
298: PetscErrorCode DSPermuteRows_Private(DS ds,PetscInt istart,PetscInt iend,PetscInt m,DSMatType mat,PetscInt *perm)
299: {
300: PetscInt i,j,k,p,ld;
301: PetscScalar *Q,rtmp;
303: ld = ds->ld;
304: MatDenseGetArray(ds->omat[mat],&Q);
305: for (i=istart;i<iend;i++) {
306: p = perm[i];
307: if (p != i) {
308: j = i + 1;
309: while (perm[j] != i) j++;
310: perm[j] = p; perm[i] = i;
311: /* swap rows i and j */
312: for (k=0;k<m;k++) {
313: rtmp = Q[p+k*ld]; Q[p+k*ld] = Q[i+k*ld]; Q[i+k*ld] = rtmp;
314: }
315: }
316: }
317: MatDenseRestoreArray(ds->omat[mat],&Q);
318: return 0;
319: }
321: /*
322: Permute columns [istart..iend-1] of [mat1] and [mat2] according to perm.
323: Columns of [mat1] have length n, columns of [mat2] have length m
324: */
325: PetscErrorCode DSPermuteBoth_Private(DS ds,PetscInt istart,PetscInt iend,PetscInt n,PetscInt m,DSMatType mat1,DSMatType mat2,PetscInt *perm)
326: {
327: PetscInt i,j,k,p,ld;
328: PetscScalar *U,*V,rtmp;
330: ld = ds->ld;
331: MatDenseGetArray(ds->omat[mat1],&U);
332: MatDenseGetArray(ds->omat[mat2],&V);
333: for (i=istart;i<iend;i++) {
334: p = perm[i];
335: if (p != i) {
336: j = i + 1;
337: while (perm[j] != i) j++;
338: perm[j] = p; perm[i] = i;
339: /* swap columns i and j of U */
340: for (k=0;k<n;k++) {
341: rtmp = U[k+p*ld]; U[k+p*ld] = U[k+i*ld]; U[k+i*ld] = rtmp;
342: }
343: /* swap columns i and j of V */
344: for (k=0;k<m;k++) {
345: rtmp = V[k+p*ld]; V[k+p*ld] = V[k+i*ld]; V[k+i*ld] = rtmp;
346: }
347: }
348: }
349: MatDenseRestoreArray(ds->omat[mat1],&U);
350: MatDenseRestoreArray(ds->omat[mat2],&V);
351: return 0;
352: }
354: /*@
355: DSSetIdentity - Copy the identity (a diagonal matrix with ones) on the
356: active part of a matrix.
358: Logically Collective on ds
360: Input Parameters:
361: + ds - the direct solver context
362: - mat - the matrix to modify
364: Level: intermediate
366: .seealso: DSGetMat()
367: @*/
368: PetscErrorCode DSSetIdentity(DS ds,DSMatType mat)
369: {
370: PetscScalar *A;
371: PetscInt i,ld,n,l;
375: DSCheckValidMat(ds,mat,2);
377: DSGetDimensions(ds,&n,&l,NULL,NULL);
378: DSGetLeadingDimension(ds,&ld);
379: PetscLogEventBegin(DS_Other,ds,0,0,0);
380: MatDenseGetArray(ds->omat[mat],&A);
381: PetscArrayzero(A+l*ld,ld*(n-l));
382: for (i=l;i<n;i++) A[i+i*ld] = 1.0;
383: MatDenseRestoreArray(ds->omat[mat],&A);
384: PetscLogEventEnd(DS_Other,ds,0,0,0);
385: return 0;
386: }
388: /*@C
389: DSOrthogonalize - Orthogonalize the columns of a matrix.
391: Logically Collective on ds
393: Input Parameters:
394: + ds - the direct solver context
395: . mat - a matrix
396: - cols - number of columns to orthogonalize (starting from column zero)
398: Output Parameter:
399: . lindcols - (optional) number of linearly independent columns of the matrix
401: Level: developer
403: .seealso: DSPseudoOrthogonalize()
404: @*/
405: PetscErrorCode DSOrthogonalize(DS ds,DSMatType mat,PetscInt cols,PetscInt *lindcols)
406: {
407: PetscInt n,l,ld;
408: PetscBLASInt ld_,rA,cA,info,ltau,lw;
409: PetscScalar *A,*tau,*w,saux,dummy;
412: DSCheckAlloc(ds,1);
414: DSCheckValidMat(ds,mat,2);
417: DSGetDimensions(ds,&n,&l,NULL,NULL);
418: DSGetLeadingDimension(ds,&ld);
419: n = n - l;
421: if (n == 0 || cols == 0) return 0;
423: PetscLogEventBegin(DS_Other,ds,0,0,0);
424: PetscFPTrapPush(PETSC_FP_TRAP_OFF);
425: MatDenseGetArray(ds->omat[mat],&A);
426: PetscBLASIntCast(PetscMin(cols,n),<au);
427: PetscBLASIntCast(ld,&ld_);
428: PetscBLASIntCast(n,&rA);
429: PetscBLASIntCast(cols,&cA);
430: lw = -1;
431: PetscCallBLAS("LAPACKgeqrf",LAPACKgeqrf_(&rA,&cA,A,&ld_,&dummy,&saux,&lw,&info));
432: SlepcCheckLapackInfo("geqrf",info);
433: lw = (PetscBLASInt)PetscRealPart(saux);
434: DSAllocateWork_Private(ds,lw+ltau,0,0);
435: tau = ds->work;
436: w = &tau[ltau];
437: PetscCallBLAS("LAPACKgeqrf",LAPACKgeqrf_(&rA,&cA,&A[ld*l+l],&ld_,tau,w,&lw,&info));
438: SlepcCheckLapackInfo("geqrf",info);
439: PetscCallBLAS("LAPACKorgqr",LAPACKorgqr_(&rA,<au,<au,&A[ld*l+l],&ld_,tau,w,&lw,&info));
440: SlepcCheckLapackInfo("orgqr",info);
441: if (lindcols) *lindcols = ltau;
442: PetscFPTrapPop();
443: MatDenseRestoreArray(ds->omat[mat],&A);
444: PetscLogEventEnd(DS_Other,ds,0,0,0);
445: PetscObjectStateIncrease((PetscObject)ds);
446: return 0;
447: }
449: /*
450: Compute C <- a*A*B + b*C, where
451: ldC, the leading dimension of C,
452: ldA, the leading dimension of A,
453: rA, cA, rows and columns of A,
454: At, if true use the transpose of A instead,
455: ldB, the leading dimension of B,
456: rB, cB, rows and columns of B,
457: Bt, if true use the transpose of B instead
458: */
459: static PetscErrorCode SlepcMatDenseMult(PetscScalar *C,PetscInt _ldC,PetscScalar b,PetscScalar a,const PetscScalar *A,PetscInt _ldA,PetscInt rA,PetscInt cA,PetscBool At,const PetscScalar *B,PetscInt _ldB,PetscInt rB,PetscInt cB,PetscBool Bt)
460: {
461: PetscInt tmp;
462: PetscBLASInt m, n, k, ldA = _ldA, ldB = _ldB, ldC = _ldC;
463: const char *N = "N", *T = "C", *qA = N, *qB = N;
465: if ((rA == 0) || (cB == 0)) return 0;
470: /* Transpose if needed */
471: if (At) tmp = rA, rA = cA, cA = tmp, qA = T;
472: if (Bt) tmp = rB, rB = cB, cB = tmp, qB = T;
474: /* Check size */
477: /* Do stub */
478: if ((rA == 1) && (cA == 1) && (cB == 1)) {
479: if (!At && !Bt) *C = *A * *B;
480: else if (At && !Bt) *C = PetscConj(*A) * *B;
481: else if (!At && Bt) *C = *A * PetscConj(*B);
482: else *C = PetscConj(*A) * PetscConj(*B);
483: m = n = k = 1;
484: } else {
485: m = rA; n = cB; k = cA;
486: PetscCallBLAS("BLASgemm",BLASgemm_(qA,qB,&m,&n,&k,&a,(PetscScalar*)A,&ldA,(PetscScalar*)B,&ldB,&b,C,&ldC));
487: }
489: PetscLogFlops(2.0*m*n*k);
490: return 0;
491: }
493: /*@C
494: DSPseudoOrthogonalize - Orthogonalize the columns of a matrix with Modified
495: Gram-Schmidt in an indefinite inner product space defined by a signature.
497: Logically Collective on ds
499: Input Parameters:
500: + ds - the direct solver context
501: . mat - the matrix
502: . cols - number of columns to orthogonalize (starting from column zero)
503: - s - the signature that defines the inner product
505: Output Parameters:
506: + lindcols - (optional) linearly independent columns of the matrix
507: - ns - (optional) the new signature of the vectors
509: Note:
510: After the call the matrix satisfies A'*s*A = ns.
512: Level: developer
514: .seealso: DSOrthogonalize()
515: @*/
516: PetscErrorCode DSPseudoOrthogonalize(DS ds,DSMatType mat,PetscInt cols,PetscReal *s,PetscInt *lindcols,PetscReal *ns)
517: {
518: PetscInt i,j,k,l,n,ld;
519: PetscBLASInt info,one=1,zero=0,rA_,ld_;
520: PetscScalar *A,*A_,*m,*h,nr0;
521: PetscReal nr_o,nr,nr_abs,*ns_,done=1.0;
524: DSCheckAlloc(ds,1);
526: DSCheckValidMat(ds,mat,2);
529: DSGetDimensions(ds,&n,&l,NULL,NULL);
530: DSGetLeadingDimension(ds,&ld);
531: n = n - l;
533: if (n == 0 || cols == 0) return 0;
534: PetscLogEventBegin(DS_Other,ds,0,0,0);
535: PetscBLASIntCast(n,&rA_);
536: PetscBLASIntCast(ld,&ld_);
537: MatDenseGetArray(ds->omat[mat],&A_);
538: A = &A_[ld*l+l];
539: DSAllocateWork_Private(ds,n+cols,ns?0:cols,0);
540: m = ds->work;
541: h = &m[n];
542: ns_ = ns ? ns : ds->rwork;
543: for (i=0; i<cols; i++) {
544: /* m <- diag(s)*A[i] */
545: for (k=0; k<n; k++) m[k] = s[k]*A[k+i*ld];
546: /* nr_o <- mynorm(A[i]'*m), mynorm(x) = sign(x)*sqrt(|x|) */
547: SlepcMatDenseMult(&nr0,1,0.0,1.0,&A[ld*i],ld,n,1,PETSC_TRUE,m,n,n,1,PETSC_FALSE);
548: nr = nr_o = PetscSign(PetscRealPart(nr0))*PetscSqrtReal(PetscAbsScalar(nr0));
549: for (j=0; j<3 && i>0; j++) {
550: /* h <- A[0:i-1]'*m */
551: SlepcMatDenseMult(h,i,0.0,1.0,A,ld,n,i,PETSC_TRUE,m,n,n,1,PETSC_FALSE);
552: /* h <- diag(ns)*h */
553: for (k=0; k<i; k++) h[k] *= ns_[k];
554: /* A[i] <- A[i] - A[0:i-1]*h */
555: SlepcMatDenseMult(&A[ld*i],ld,1.0,-1.0,A,ld,n,i,PETSC_FALSE,h,i,i,1,PETSC_FALSE);
556: /* m <- diag(s)*A[i] */
557: for (k=0; k<n; k++) m[k] = s[k]*A[k+i*ld];
558: /* nr_o <- mynorm(A[i]'*m) */
559: SlepcMatDenseMult(&nr0,1,0.0,1.0,&A[ld*i],ld,n,1,PETSC_TRUE,m,n,n,1,PETSC_FALSE);
560: nr = PetscSign(PetscRealPart(nr0))*PetscSqrtReal(PetscAbsScalar(nr0));
562: if (PetscAbs(nr) > 0.7*PetscAbs(nr_o)) break;
563: nr_o = nr;
564: }
565: ns_[i] = PetscSign(nr);
566: /* A[i] <- A[i]/|nr| */
567: nr_abs = PetscAbs(nr);
568: PetscCallBLAS("LAPACKlascl",LAPACKlascl_("G",&zero,&zero,&nr_abs,&done,&rA_,&one,A+i*ld,&ld_,&info));
569: SlepcCheckLapackInfo("lascl",info);
570: }
571: MatDenseRestoreArray(ds->omat[mat],&A_);
572: PetscLogEventEnd(DS_Other,ds,0,0,0);
573: PetscObjectStateIncrease((PetscObject)ds);
574: if (lindcols) *lindcols = cols;
575: return 0;
576: }