1: /*
2: BV orthogonalization routines.
4: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5: SLEPc - Scalable Library for Eigenvalue Problem Computations
6: Copyright (c) 2002-2015, Universitat Politecnica de Valencia, Spain
8: This file is part of SLEPc.
10: SLEPc is free software: you can redistribute it and/or modify it under the
11: terms of version 3 of the GNU Lesser General Public License as published by
12: the Free Software Foundation.
14: SLEPc is distributed in the hope that it will be useful, but WITHOUT ANY
15: WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
16: FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for
17: more details.
19: You should have received a copy of the GNU Lesser General Public License
20: along with SLEPc. If not, see <http://www.gnu.org/licenses/>.
21: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
22: */
24: #include <slepc/private/bvimpl.h> /*I "slepcbv.h" I*/
25: #include <slepcblaslapack.h>
29: /*
30: BVOrthogonalizeMGS1 - Compute one step of Modified Gram-Schmidt
31: */
32: static PetscErrorCode BVOrthogonalizeMGS1(BV bv,PetscInt k,Vec v,PetscBool *which,PetscScalar *H) 33: {
35: PetscInt i;
36: PetscScalar dot;
37: Vec vi,z;
40: z = v;
41: for (i=-bv->nc;i<k;i++) {
42: if (which && i>=0 && !which[i]) continue;
43: BVGetColumn(bv,i,&vi);
44: /* h_i = ( v, v_i ) */
45: if (bv->matrix) {
46: BV_IPMatMult(bv,v);
47: z = bv->Bx;
48: }
49: VecDot(z,vi,&dot);
50: /* v <- v - h_i v_i */
51: if (bv->indef) dot /= bv->omega[bv->nc+i];
52: VecAXPY(v,-dot,vi);
53: if (bv->indef) dot *= bv->omega[bv->nc+i];
54: if (H) H[bv->nc+i] += dot;
55: BVRestoreColumn(bv,i,&vi);
56: }
57: return(0);
58: }
62: /*
63: BVOrthogonalizeCGS1 - Compute |v'| (estimated), |v| and one step of CGS with
64: only one global synchronization
65: */
66: PetscErrorCode BVOrthogonalizeCGS1(BV bv,PetscInt j,Vec v,PetscScalar *H,PetscReal *onorm,PetscReal *norm) 67: {
69: PetscInt i;
70: PetscReal sum,nrm,beta;
71: Vec w=v;
74: /* h = W^* v ; alpha = (v, v) */
75: bv->k = j;
76: if (onorm || norm) {
77: if (!v) {
78: bv->k++;
79: BVGetColumn(bv,j,&w);
80: }
81: BVDotVec(bv,w,H);
82: if (!v) {
83: BVRestoreColumn(bv,j,&w);
84: bv->k--;
85: beta = PetscSqrtReal(PetscRealPart(H[bv->nc+j]));
86: } else {
87: BVNormVec(bv,w,NORM_2,&beta);
88: }
89: } else {
90: if (!v) { BVDotColumn(bv,j,H); }
91: else { BVDotVec(bv,w,H); }
92: }
94: /* q = v - V h */
95: if (bv->indef) {
96: for (i=0;i<bv->nc+j;i++) H[i] /= bv->omega[i]; /* apply inverse of signature */
97: }
98: if (!v) { BVMultColumn(bv,-1.0,1.0,j,H); }
99: else { BVMultVec(bv,-1.0,1.0,w,H); }
100: if (bv->indef) {
101: for (i=0;i<bv->nc+j;i++) H[i] *= bv->omega[i]; /* revert signature */
102: }
104: /* compute |v| */
105: if (onorm) *onorm = beta;
107: if (bv->indef) {
108: if (!v) { BVNormColumn(bv,j,NORM_2,&nrm); }
109: else { BVNormVec(bv,w,NORM_2,&nrm); }
110: if (norm) *norm = nrm;
111: bv->omega[bv->nc+j] = (nrm<0.0)? -1.0: 1.0;
112: } else if (norm) {
113: /* estimate |v'| from |v| */
114: sum = 0.0;
115: for (i=0;i<bv->nc+j;i++) sum += PetscRealPart(H[i]*PetscConj(H[i]));
116: *norm = beta*beta-sum;
117: if (*norm <= 0.0) {
118: if (!v) { BVNormColumn(bv,j,NORM_2,norm); }
119: else { BVNormVec(bv,w,NORM_2,norm); }
120: } else *norm = PetscSqrtReal(*norm);
121: }
122: return(0);
123: }
127: /*
128: BVOrthogonalizeMGS - Orthogonalize with modified Gram-Schmidt
129: */
130: static PetscErrorCode BVOrthogonalizeMGS(BV bv,PetscInt j,Vec v,PetscBool *which,PetscScalar *H,PetscReal *norm,PetscBool *lindep)131: {
133: PetscReal onrm,nrm;
134: PetscInt k,l;
135: Vec w;
138: if (v) {
139: w = v;
140: k = bv->k;
141: } else {
142: BVGetColumn(bv,j,&w);
143: k = j;
144: }
145: PetscMemzero(bv->h,(bv->nc+k)*sizeof(PetscScalar));
146: switch (bv->orthog_ref) {
148: case BV_ORTHOG_REFINE_IFNEEDED:
149: /* first step */
150: BVNormVec(bv,w,NORM_2,&onrm);
151: BVOrthogonalizeMGS1(bv,k,w,which,bv->h);
152: BVNormVec(bv,w,NORM_2,&nrm);
153: /* ||q|| < eta ||h|| */
154: l = 1;
155: while (l<3 && nrm && nrm < bv->orthog_eta*onrm) {
156: l++;
157: onrm = nrm;
158: BVOrthogonalizeMGS1(bv,k,w,which,bv->c);
159: BVNormVec(bv,w,NORM_2,&nrm);
160: }
161: if (lindep) {
162: if (nrm < bv->orthog_eta*onrm) *lindep = PETSC_TRUE;
163: else *lindep = PETSC_FALSE;
164: }
165: break;
167: case BV_ORTHOG_REFINE_NEVER:
168: BVOrthogonalizeMGS1(bv,k,w,which,bv->h);
169: /* compute |v| */
170: if (norm || lindep) {
171: BVNormVec(bv,w,NORM_2,&nrm);
172: }
173: /* linear dependence check: just test for exactly zero norm */
174: if (lindep) *lindep = nrm? PETSC_FALSE: PETSC_TRUE;
175: break;
177: case BV_ORTHOG_REFINE_ALWAYS:
178: /* first step */
179: BVOrthogonalizeMGS1(bv,k,w,which,bv->h);
180: if (lindep) {
181: BVNormVec(bv,w,NORM_2,&onrm);
182: }
183: /* second step */
184: BVOrthogonalizeMGS1(bv,k,w,which,bv->h);
185: if (norm || lindep) {
186: BVNormVec(bv,w,NORM_2,&nrm);
187: }
188: if (lindep) {
189: if (nrm==0.0 || nrm < bv->orthog_eta*onrm) *lindep = PETSC_TRUE;
190: else *lindep = PETSC_FALSE;
191: }
192: break;
193: }
194: if (bv->indef) {
195: BVNormVec(bv,w,NORM_2,&nrm);
196: bv->omega[bv->nc+j] = (nrm<0.0)? -1.0: 1.0;
197: }
198: if (!v) { BVRestoreColumn(bv,j,&w); }
199: if (norm) *norm = nrm;
200: return(0);
201: }
205: /*
206: BVOrthogonalizeCGS - Orthogonalize with classical Gram-Schmidt
207: */
208: static PetscErrorCode BVOrthogonalizeCGS(BV bv,PetscInt j,Vec v,PetscScalar *H,PetscReal *norm,PetscBool *lindep)209: {
211: PetscReal onrm,nrm;
212: PetscInt i,k,l;
215: if (v) k = bv->k;
216: else k = j;
217: switch (bv->orthog_ref) {
219: case BV_ORTHOG_REFINE_IFNEEDED:
220: BVOrthogonalizeCGS1(bv,k,v,bv->h,&onrm,&nrm);
221: /* ||q|| < eta ||h|| */
222: l = 1;
223: while (l<3 && nrm && nrm < bv->orthog_eta*onrm) {
224: l++;
225: BVOrthogonalizeCGS1(bv,k,v,bv->c,&onrm,&nrm);
226: for (i=0;i<bv->nc+k;i++) bv->h[i] += bv->c[i];
227: }
228: if (norm) *norm = nrm;
229: if (lindep) {
230: if (nrm < bv->orthog_eta*onrm) *lindep = PETSC_TRUE;
231: else *lindep = PETSC_FALSE;
232: }
233: break;
235: case BV_ORTHOG_REFINE_NEVER:
236: BVOrthogonalizeCGS1(bv,k,v,bv->h,NULL,NULL);
237: /* compute |v| */
238: if (norm || lindep) {
239: if (v) { BVNormVec(bv,v,NORM_2,&nrm); }
240: else { BVNormColumn(bv,k,NORM_2,&nrm); }
241: }
242: if (norm) *norm = nrm;
243: /* linear dependence check: just test for exactly zero norm */
244: if (lindep) *lindep = nrm? PETSC_FALSE: PETSC_TRUE;
245: break;
247: case BV_ORTHOG_REFINE_ALWAYS:
248: BVOrthogonalizeCGS1(bv,k,v,bv->h,NULL,NULL);
249: if (lindep) {
250: BVOrthogonalizeCGS1(bv,k,v,bv->c,&onrm,&nrm);
251: if (norm) *norm = nrm;
252: if (nrm==0.0 || nrm < bv->orthog_eta*onrm) *lindep = PETSC_TRUE;
253: else *lindep = PETSC_FALSE;
254: } else {
255: BVOrthogonalizeCGS1(bv,k,v,bv->c,NULL,norm);
256: }
257: for (i=0;i<bv->nc+k;i++) bv->h[i] += bv->c[i];
258: break;
259: }
260: return(0);
261: }
265: /*@
266: BVOrthogonalizeVec - Orthogonalize a given vector with respect to all
267: active columns.
269: Collective on BV271: Input Parameters:
272: + bv - the basis vectors context
273: - v - the vector
275: Output Parameters:
276: + H - (optional) coefficients computed during orthogonalization
277: . norm - (optional) norm of the vector after being orthogonalized
278: - lindep - (optional) flag indicating that refinement did not improve the quality
279: of orthogonalization
281: Notes:
282: This function is equivalent to BVOrthogonalizeColumn() but orthogonalizes
283: a vector as an argument rather than taking one of the BV columns. The
284: vector is orthogonalized against all active columns.
286: Level: advanced
288: .seealso: BVOrthogonalizeColumn(), BVSetOrthogonalization(), BVSetActiveColumns()
289: @*/
290: PetscErrorCode BVOrthogonalizeVec(BV bv,Vec v,PetscScalar *H,PetscReal *norm,PetscBool *lindep)291: {
293: PetscInt i,ksave,lsave;
299: BVCheckSizes(bv,1);
303: PetscLogEventBegin(BV_Orthogonalize,bv,0,0,0);
304: ksave = bv->k;
305: lsave = bv->l;
306: bv->l = -bv->nc; /* must also orthogonalize against constraints and leading columns */
307: BV_AllocateCoeffs(bv);
308: BV_AllocateSignature(bv);
309: switch (bv->orthog_type) {
310: case BV_ORTHOG_CGS:
311: BVOrthogonalizeCGS(bv,0,v,H,norm,lindep);
312: break;
313: case BV_ORTHOG_MGS:
314: BVOrthogonalizeMGS(bv,0,v,NULL,H,norm,lindep);
315: break;
316: }
317: bv->k = ksave;
318: bv->l = lsave;
319: if (H) for (i=bv->l;i<bv->k;i++) H[i-bv->l] = bv->h[bv->nc+i];
320: PetscLogEventEnd(BV_Orthogonalize,bv,0,0,0);
321: return(0);
322: }
326: /*@
327: BVOrthogonalizeColumn - Orthogonalize one of the column vectors with respect to
328: the previous ones.
330: Collective on BV332: Input Parameters:
333: + bv - the basis vectors context
334: - j - index of column to be orthogonalized
336: Output Parameters:
337: + H - (optional) coefficients computed during orthogonalization
338: . norm - (optional) norm of the vector after being orthogonalized
339: - lindep - (optional) flag indicating that refinement did not improve the quality
340: of orthogonalization
342: Notes:
343: This function applies an orthogonal projector to project vector V[j] onto
344: the orthogonal complement of the span of the columns of V[0..j-1],
345: where V[.] are the vectors of BV. The columns V[0..j-1] are assumed to be
346: mutually orthonormal.
348: Leading columns V[0..l-1] also participate in the orthogonalization.
350: If a non-standard inner product has been specified with BVSetMatrix(),
351: then the vector is B-orthogonalized, using the non-standard inner product
352: defined by matrix B. The output vector satisfies V[j]'*B*V[0..j-1] = 0.
354: This routine does not normalize the resulting vector.
356: Level: advanced
358: .seealso: BVSetOrthogonalization(), BVSetMatrix(), BVSetActiveColumns(), BVOrthogonalize(), BVOrthogonalizeVec()
359: @*/
360: PetscErrorCode BVOrthogonalizeColumn(BV bv,PetscInt j,PetscScalar *H,PetscReal *norm,PetscBool *lindep)361: {
363: PetscInt i,ksave,lsave;
369: BVCheckSizes(bv,1);
370: if (j<0) SETERRQ(PetscObjectComm((PetscObject)bv),PETSC_ERR_ARG_OUTOFRANGE,"Index j must be non-negative");
371: if (j>=bv->m) SETERRQ2(PetscObjectComm((PetscObject)bv),PETSC_ERR_ARG_OUTOFRANGE,"Index j=%D but BV only has %D columns",j,bv->m);
373: PetscLogEventBegin(BV_Orthogonalize,bv,0,0,0);
374: ksave = bv->k;
375: lsave = bv->l;
376: bv->l = -bv->nc; /* must also orthogonalize against constraints and leading columns */
377: BV_AllocateCoeffs(bv);
378: BV_AllocateSignature(bv);
379: switch (bv->orthog_type) {
380: case BV_ORTHOG_CGS:
381: BVOrthogonalizeCGS(bv,j,NULL,H,norm,lindep);
382: break;
383: case BV_ORTHOG_MGS:
384: BVOrthogonalizeMGS(bv,j,NULL,NULL,H,norm,lindep);
385: break;
386: }
387: bv->k = ksave;
388: bv->l = lsave;
389: if (H) for (i=bv->l;i<j;i++) H[i-bv->l] = bv->h[bv->nc+i];
390: PetscLogEventEnd(BV_Orthogonalize,bv,0,0,0);
391: return(0);
392: }
396: /*@
397: BVOrthogonalizeSomeColumn - Orthogonalize one of the column vectors with
398: respect to some of the previous ones.
400: Collective on BV402: Input Parameters:
403: + bv - the basis vectors context
404: . j - index of column to be orthogonalized
405: - which - logical array indicating selected columns
407: Output Parameters:
408: + H - (optional) coefficients computed during orthogonalization
409: . norm - (optional) norm of the vector after being orthogonalized
410: - lindep - (optional) flag indicating that refinement did not improve the quality
411: of orthogonalization
413: Notes:
414: This function is similar to BVOrthogonalizeColumn(), but V[j] is
415: orthogonalized only against columns V[i] having which[i]=PETSC_TRUE.
416: The length of array which must be j at least.
418: The use of this operation is restricted to MGS orthogonalization type.
420: Level: advanced
422: .seealso: BVOrthogonalizeColumn(), BVSetOrthogonalization()
423: @*/
424: PetscErrorCode BVOrthogonalizeSomeColumn(BV bv,PetscInt j,PetscBool *which,PetscScalar *H,PetscReal *norm,PetscBool *lindep)425: {
427: PetscInt i,ksave,lsave;
434: BVCheckSizes(bv,1);
435: if (j<0) SETERRQ(PetscObjectComm((PetscObject)bv),PETSC_ERR_ARG_OUTOFRANGE,"Index j must be non-negative");
436: if (j>=bv->m) SETERRQ2(PetscObjectComm((PetscObject)bv),PETSC_ERR_ARG_OUTOFRANGE,"Index j=%D but BV only has %D columns",j,bv->m);
437: if (bv->orthog_type!=BV_ORTHOG_MGS) SETERRQ(PetscObjectComm((PetscObject)bv),PETSC_ERR_SUP,"Operation only available for MGS orthogonalization");
439: PetscLogEventBegin(BV_Orthogonalize,bv,0,0,0);
440: ksave = bv->k;
441: lsave = bv->l;
442: bv->l = -bv->nc; /* must also orthogonalize against constraints and leading columns */
443: BV_AllocateCoeffs(bv);
444: BV_AllocateSignature(bv);
445: BVOrthogonalizeMGS(bv,j,NULL,which,H,norm,lindep);
446: bv->k = ksave;
447: bv->l = lsave;
448: if (H) for (i=bv->l;i<j;i++) H[i-bv->l] = bv->h[bv->nc+i];
449: PetscLogEventEnd(BV_Orthogonalize,bv,0,0,0);
450: return(0);
451: }
455: /*
456: Orthogonalize a set of vectors with Gram-Schmidt, column by column.
457: */
458: static PetscErrorCode BVOrthogonalize_GS(BV V,Mat R)459: {
461: PetscScalar *r=NULL;
462: PetscReal norm;
463: PetscInt j,ldr;
464: Vec v;
467: if (R) {
468: MatGetSize(R,&ldr,NULL);
469: MatDenseGetArray(R,&r);
470: }
471: if (V->matrix) {
472: BV_AllocateCachedBV(V);
473: BVSetActiveColumns(V->cached,V->l,V->k);
474: }
475: for (j=V->l;j<V->k;j++) {
476: if (R) {
477: BVOrthogonalizeColumn(V,j,r+j*ldr+V->l,&norm,NULL);
478: r[j+j*ldr] = norm;
479: } else {
480: BVOrthogonalizeColumn(V,j,NULL,&norm,NULL);
481: }
482: if (V->matrix) { /* fill cached BV */
483: BVGetColumn(V->cached,j,&v);
484: VecCopy(V->Bx,v);
485: BVRestoreColumn(V->cached,j,&v);
486: }
487: BVScaleColumn(V,j,1.0/norm);
488: }
489: if (R) { MatDenseRestoreArray(R,&r); }
490: return(0);
491: }
495: /*
496: Compute the upper Cholesky factor in R and its inverse in S.
497: */
498: static PetscErrorCode MatCholeskyFactorInvert(Mat R,PetscInt l,Mat *S)499: {
501: PetscInt i,n,m,ld;
502: PetscScalar *pR,*pS,done=1.0;
503: PetscBLASInt info,n_,l_,m_,ld_;
506: MatGetSize(R,&m,NULL);
507: n = m-l;
508: PetscBLASIntCast(m,&m_);
509: PetscBLASIntCast(l,&l_);
510: PetscBLASIntCast(n,&n_);
511: ld = m;
512: ld_ = m_;
513: MatCreateSeqDense(PETSC_COMM_SELF,ld,ld,NULL,S);
514: MatDenseGetArray(R,&pR);
515: MatDenseGetArray(*S,&pS);
517: /* compute upper Cholesky factor in R */
518: PetscStackCallBLAS("LAPACKpotrf",LAPACKpotrf_("U",&n_,pR+l*ld+l,&ld_,&info));
519: if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_MAT_CH_ZRPVT,"Error in Cholesky factorization, info=%D",(PetscInt)info);
520: PetscLogFlops((1.0*n*n*n)/3.0);
522: /* build identity and compute S = R\I */
523: PetscMemzero(pS,m*m*sizeof(PetscScalar));
524: for (i=0;i<m;i++) pS[i+i*ld] = 1.0;
525: PetscStackCallBLAS("BLAStrsm",BLAStrsm_("L","U","N","N",&n_,&n_,&done,pR+l*ld+l,&ld_,pS+l*ld+l,&ld_));
527: /* Zero out entries below the diagonal */
528: for (i=l;i<m-1;i++) {
529: PetscMemzero(pR+i*ld+i+1,(m-i-1)*sizeof(PetscScalar));
530: PetscMemzero(pS+i*ld+i+1,(m-i-1)*sizeof(PetscScalar));
531: }
532: MatDenseRestoreArray(R,&pR);
533: MatDenseRestoreArray(*S,&pS);
534: return(0);
535: }
539: /*
540: Orthogonalize a set of vectors with Cholesky: R=chol(V'*V), Q=V*inv(R)
541: */
542: static PetscErrorCode BVOrthogonalize_Chol(BV V,Mat Rin)543: {
545: Mat S,R=Rin,B;
548: if (!Rin) {
549: MatCreateSeqDense(PETSC_COMM_SELF,V->k,V->k,NULL,&R);
550: }
551: if (V->matrix) {
552: BV_IPMatMultBV(V);
553: B = V->matrix;
554: V->matrix = NULL;
555: BVDot(V->cached,V,R);
556: V->matrix = B;
557: } else {
558: BVDot(V,V,R);
559: }
560: MatCholeskyFactorInvert(R,V->l,&S);
561: BVMultInPlace(V,S,V->l,V->k);
562: MatDestroy(&S);
563: if (!Rin) {
564: MatDestroy(&R);
565: }
566: return(0);
567: }
571: /*@
572: BVOrthogonalize - Orthogonalize all columns (except leading ones), that is,
573: compute the QR decomposition.
575: Collective on BV577: Input Parameter:
578: . V - basis vectors
580: Output Parameters:
581: + V - the modified basis vectors
582: - R - a sequential dense matrix (or NULL)
584: Notes:
585: On input, matrix R must be a sequential dense Mat, with at least as many rows
586: and columns as the number of active columns of V. The output satisfies
587: V0 = V*R (where V0 represent the input V) and V'*V = I.
589: If V has leading columns, then they are not modified (are assumed to be already
590: orthonormal) and the corresponding part of R is not referenced.
592: Can pass NULL if R is not required.
594: The method to be used for block orthogonalization can be set with
595: BVSetOrthogonalization(). If set to GS, the computation is done column by
596: column with successive calls to BVOrthogonalizeColumn().
598: Level: intermediate
600: .seealso: BVOrthogonalizeColumn(), BVOrthogonalizeVec(), BVSetActiveColumns(), BVSetOrthogonalization(), BVOrthogBlockType601: @*/
602: PetscErrorCode BVOrthogonalize(BV V,Mat R)603: {
605: PetscBool match;
606: PetscInt m,n;
611: BVCheckSizes(V,1);
612: if (R) {
615: if (V->l>0 && V->orthog_block==BV_ORTHOG_BLOCK_GS) SETERRQ(PetscObjectComm((PetscObject)V),PETSC_ERR_SUP,"Cannot request matrix R in Gram-Schmidt orthogonalization if l>0");
616: PetscObjectTypeCompare((PetscObject)R,MATSEQDENSE,&match);
617: if (!match) SETERRQ(PetscObjectComm((PetscObject)V),PETSC_ERR_SUP,"Mat argument must be of type seqdense");
618: MatGetSize(R,&m,&n);
619: if (m!=n) SETERRQ2(PetscObjectComm((PetscObject)V),PETSC_ERR_ARG_SIZ,"Mat argument is not square, it has %D rows and %D columns",m,n);
620: if (n<V->k) SETERRQ2(PetscObjectComm((PetscObject)V),PETSC_ERR_ARG_SIZ,"Mat size %D is smaller than the number of BV active columns %D",n,V->k);
621: }
622: if (V->nc) SETERRQ(PetscObjectComm((PetscObject)V),PETSC_ERR_SUP,"Not implemented for BV with constraints, use BVOrthogonalizeColumn() instead");
624: PetscLogEventBegin(BV_Orthogonalize,V,R,0,0);
625: switch (V->orthog_block) {
626: case BV_ORTHOG_BLOCK_GS: /* proceed column by column with Gram-Schmidt */
627: BVOrthogonalize_GS(V,R);
628: break;
629: case BV_ORTHOG_BLOCK_CHOL:
630: BVOrthogonalize_Chol(V,R);
631: /*if (V->ops->orthogonalize) {
632: (*V->ops->orthogonalize)(V,R);
633: }*/
634: break;
635: }
636: PetscLogEventEnd(BV_Orthogonalize,V,R,0,0);
637: PetscObjectStateIncrease((PetscObject)V);
638: return(0);
639: }