Actual source code: ipbiorthog.c
1: /*
2: Routines related to bi-orthogonalization.
3: See the SLEPc Technical Report STR-1 for a detailed explanation.
5: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
6: SLEPc - Scalable Library for Eigenvalue Problem Computations
7: Copyright (c) 2002-2013, Universitat Politecnica de Valencia, Spain
9: This file is part of SLEPc.
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 <slepc-private/ipimpl.h> /*I "slepcip.h" I*/
26: #include <slepcblaslapack.h>
28: /*
29: Biorthogonalization routine using classical Gram-Schmidt with refinement.
30: */
33: static PetscErrorCode IPCGSBiOrthogonalization(IP ip,PetscInt n_,Vec *V,Vec *W,Vec v,PetscScalar *H,PetscReal *hnorm,PetscReal *norm)
34: {
35: #if defined(SLEPC_MISSING_LAPACK_GELQF) || defined(SLEPC_MISSING_LAPACK_ORMLQ)
37: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GELQF/ORMLQ - Lapack routine is unavailable");
38: #else
40: PetscBLASInt j,ione=1,lwork,info,n=n_;
41: PetscScalar shh[100],*lhh,*vw,*tau,one=1.0,*work;
44: /* Don't allocate small arrays */
45: if (n<=100) lhh = shh;
46: else {
47: PetscMalloc(n*sizeof(PetscScalar),&lhh);
48: }
49: PetscMalloc(n*n*sizeof(PetscScalar),&vw);
51: for (j=0;j<n;j++) {
52: IPMInnerProduct(ip,V[j],n,W,vw+j*n);
53: }
54: lwork = n;
55: PetscMalloc(n*sizeof(PetscScalar),&tau);
56: PetscMalloc(lwork*sizeof(PetscScalar),&work);
57: PetscFPTrapPush(PETSC_FP_TRAP_OFF);
58: PetscStackCallBLAS("LAPACKgelqf",LAPACKgelqf_(&n,&n,vw,&n,tau,work,&lwork,&info));
59: PetscFPTrapPop();
60: if (info) SETERRQ1(PetscObjectComm((PetscObject)ip),PETSC_ERR_LIB,"Error in Lapack xGELQF %d",info);
62: /*** First orthogonalization ***/
64: /* h = W^* v */
65: /* q = v - V h */
66: IPMInnerProduct(ip,v,n,W,H);
67: PetscFPTrapPush(PETSC_FP_TRAP_OFF);
68: PetscStackCallBLAS("BLAStrsm",BLAStrsm_("L","L","N","N",&n,&ione,&one,vw,&n,H,&n));
69: PetscStackCallBLAS("LAPACKormlq",LAPACKormlq_("L","N",&n,&ione,&n,vw,&n,tau,H,&n,work,&lwork,&info));
70: PetscFPTrapPop();
71: if (info) SETERRQ1(PetscObjectComm((PetscObject)ip),PETSC_ERR_LIB,"Error in Lapack xORMLQ %d",info);
72: SlepcVecMAXPBY(v,1.0,-1.0,n,H,V);
74: /* compute norm of v */
75: if (norm) { IPNorm(ip,v,norm); }
77: if (n>100) { PetscFree(lhh); }
78: PetscFree(vw);
79: PetscFree(tau);
80: PetscFree(work);
81: return(0);
82: #endif
83: }
87: /*@
88: IPBiOrthogonalize - Bi-orthogonalize a vector with respect to a set of vectors.
90: Collective on IP and Vec
92: Input Parameters:
93: + ip - the inner product context
94: . n - number of columns of V
95: . V - set of vectors
96: - W - set of vectors
98: Input/Output Parameter:
99: . v - vector to be orthogonalized
101: Output Parameter:
102: + H - coefficients computed during orthogonalization
103: - norm - norm of the vector after being orthogonalized
105: Notes:
106: This function applies an oblique projector to project vector v onto the
107: span of the columns of V along the orthogonal complement of the column
108: space of W.
110: On exit, v0 = [V v]*H, where v0 is the original vector v.
112: This routine does not normalize the resulting vector.
114: Level: developer
116: .seealso: IPSetOrthogonalization(), IPOrthogonalize()
117: @*/
118: PetscErrorCode IPBiOrthogonalize(IP ip,PetscInt n,Vec *V,Vec *W,Vec v,PetscScalar *H,PetscReal *norm)
119: {
121: PetscScalar lh[100],*h;
122: PetscBool allocated = PETSC_FALSE;
123: PetscReal lhnrm,*hnrm,lnrm,*nrm;
128: if (!n) {
129: if (norm) { IPNorm(ip,v,norm); }
130: } else {
131: PetscLogEventBegin(IP_Orthogonalize,ip,0,0,0);
132: /* allocate H if needed */
133: if (!H) {
134: if (n<=100) h = lh;
135: else {
136: PetscMalloc(n*sizeof(PetscScalar),&h);
137: allocated = PETSC_TRUE;
138: }
139: } else h = H;
141: /* retrieve hnrm and nrm for linear dependence check or conditional refinement */
142: if (ip->orthog_ref == IP_ORTHOG_REFINE_IFNEEDED) {
143: hnrm = &lhnrm;
144: if (norm) nrm = norm;
145: else nrm = &lnrm;
146: } else {
147: hnrm = NULL;
148: nrm = norm;
149: }
151: switch (ip->orthog_type) {
152: case IP_ORTHOG_CGS:
153: IPCGSBiOrthogonalization(ip,n,V,W,v,h,hnrm,nrm);
154: break;
155: default:
156: SETERRQ(PetscObjectComm((PetscObject)ip),PETSC_ERR_ARG_WRONG,"Unknown orthogonalization type");
157: }
159: if (allocated) { PetscFree(h); }
160: PetscLogEventEnd(IP_Orthogonalize,ip,0,0,0);
161: }
162: return(0);
163: }
165: /*
166: IPPseudoOrthogonalizeCGS1 - Compute |v'| (estimated), |v| and one step of CGS with only one global synchronization (indefinite)
167: */
170: PetscErrorCode IPPseudoOrthogonalizeCGS1(IP ip,PetscInt n,Vec *V,PetscReal* omega,Vec v,PetscScalar *H,PetscReal *onorm,PetscReal *norm)
171: {
173: PetscInt j;
174: PetscScalar alpha;
175: PetscReal sum;
178: /* h = W^* v ; alpha = (v , v) */
179: if (!onorm && !norm) {
180: /* use simpler function */
181: IPMInnerProduct(ip,v,n,V,H);
182: } else {
183: /* merge comunications */
184: IPMInnerProductBegin(ip,v,n,V,H);
185: if (onorm || (norm && !ip->matrix)) {
186: IPInnerProductBegin(ip,v,v,&alpha);
187: }
189: IPMInnerProductEnd(ip,v,n,V,H);
190: if (onorm || (norm && !ip->matrix)) {
191: IPInnerProductEnd(ip,v,v,&alpha);
192: }
193: }
195: /* q = v - V h */
196: for (j=0;j<n;j++) H[j] /= omega[j]; /* apply inverse of signature */
197: SlepcVecMAXPBY(v,1.0,-1.0,n,H,V);
198: for (j=0;j<n;j++) H[j] *= omega[j]; /* revert signature */
200: /* compute |v| */
201: if (onorm) {
202: if (PetscRealPart(alpha)>0.0) *onorm = PetscSqrtReal(PetscRealPart(alpha));
203: else *onorm = -PetscSqrtReal(-PetscRealPart(alpha));
204: }
206: if (norm) {
207: if (!ip->matrix) {
208: /* estimate |v'| from |v| */
209: sum = 0.0;
210: for (j=0; j<n; j++)
211: sum += PetscRealPart(H[j] * PetscConj(H[j]));
212: *norm = PetscRealPart(alpha)-sum;
213: if (*norm <= 0.0) {
214: IPNorm(ip,v,norm);
215: } else *norm = PetscSqrtReal(*norm);
216: } else {
217: /* compute |v'| */
218: IPNorm(ip,v,norm);
219: }
220: }
221: return(0);
222: }
224: /*
225: IPPseudoOrthogonalizeCGS - Orthogonalize with classical Gram-Schmidt (indefinite)
226: */
229: static PetscErrorCode IPPseudoOrthogonalizeCGS(IP ip,PetscInt n,Vec *V,PetscReal *omega,Vec v,PetscScalar *H,PetscReal *norm,PetscBool *lindep)
230: {
232: PetscScalar *h,*c;
233: PetscReal onrm,nrm;
234: PetscInt sz=0,sz1,j,k;
237: /* allocate h and c if needed */
238: if (!H) sz = n;
239: sz1 = sz;
240: if (ip->orthog_ref != IP_ORTHOG_REFINE_NEVER) sz += n;
241: if (sz>ip->lwork) {
242: PetscFree(ip->work);
243: PetscMalloc(sz*sizeof(PetscScalar),&ip->work);
244: PetscLogObjectMemory(ip,(sz-ip->lwork)*sizeof(PetscScalar));
245: ip->lwork = sz;
246: }
247: if (!H) h = ip->work;
248: else h = H;
249: if (ip->orthog_ref != IP_ORTHOG_REFINE_NEVER) c = ip->work + sz1;
251: /* orthogonalize and compute onorm */
252: switch (ip->orthog_ref) {
254: case IP_ORTHOG_REFINE_NEVER:
255: IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,h,NULL,NULL);
256: /* compute |v| */
257: if (norm) { IPNorm(ip,v,norm); }
258: /* linear dependence check does not work without refinement */
259: if (lindep) *lindep = PETSC_FALSE;
260: break;
262: case IP_ORTHOG_REFINE_ALWAYS:
263: IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,h,NULL,NULL);
264: if (lindep) {
265: IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,c,&onrm,&nrm);
266: if (norm) *norm = nrm;
267: if (PetscAbs(nrm) < ip->orthog_eta * PetscAbs(onrm)) *lindep = PETSC_TRUE;
268: else *lindep = PETSC_FALSE;
269: } else {
270: IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,c,NULL,norm);
271: }
272: for (j=0;j<n;j++)
273: h[j] += c[j];
274: break;
276: case IP_ORTHOG_REFINE_IFNEEDED:
277: IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,h,&onrm,&nrm);
278: /* ||q|| < eta ||h|| */
279: k = 1;
280: while (k<3 && PetscAbs(nrm) < ip->orthog_eta * PetscAbs(onrm)) {
281: k++;
282: if (!ip->matrix) {
283: IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,c,&onrm,&nrm);
284: } else {
285: onrm = nrm;
286: IPPseudoOrthogonalizeCGS1(ip,n,V,omega,v,c,NULL,&nrm);
287: }
288: for (j=0;j<n;j++)
289: h[j] += c[j];
290: }
291: if (norm) *norm = nrm;
292: if (lindep) {
293: if (PetscAbs(nrm) < ip->orthog_eta * PetscAbs(onrm)) *lindep = PETSC_TRUE;
294: else *lindep = PETSC_FALSE;
295: }
296: break;
298: default:
299: SETERRQ(PetscObjectComm((PetscObject)ip),PETSC_ERR_ARG_WRONG,"Unknown orthogonalization refinement");
300: }
302: /* recover H from workspace */
303: if (H) {
304: for (j=0;j<n;j++)
305: H[j] = h[j];
306: }
307: return(0);
308: }
312: /*@
313: IPPseudoOrthogonalize - Orthogonalize a vector with respect to two set of vectors
314: in the sense of a pseudo-inner product.
316: Collective on IP and Vec
318: Input Parameters:
319: + ip - the inner product (IP) context
320: . n - number of columns of V
321: . V - set of vectors
322: - omega - set of signs that define a signature matrix
324: Input/Output Parameter:
325: . v - (input) vector to be orthogonalized and (output) result of
326: orthogonalization
328: Output Parameter:
329: + H - coefficients computed during orthogonalization
330: . norm - norm of the vector after being orthogonalized
331: - lindep - flag indicating that refinement did not improve the quality
332: of orthogonalization
334: Notes:
335: This function is the analogue of IPOrthogonalize, but for the indefinite
336: case. When using an indefinite IP the norm is not well defined, so we
337: take the convention of having negative norms in such cases. The
338: orthogonalization is then defined by a set of vectors V satisfying
339: V'*B*V=Omega, where Omega is a signature matrix diag([+/-1,...,+/-1]).
341: On exit, v = v0 - V*Omega*H, where v0 is the original vector v.
343: This routine does not normalize the resulting vector. The output
344: argument 'norm' may be negative.
346: Level: developer
348: .seealso: IPSetOrthogonalization(), IPOrthogonalize()
349: @*/
350: PetscErrorCode IPPseudoOrthogonalize(IP ip,PetscInt n,Vec *V,PetscReal *omega,Vec v,PetscScalar *H,PetscReal *norm,PetscBool *lindep)
351: {
357: PetscLogEventBegin(IP_Orthogonalize,ip,0,0,0);
358: if (n==0) {
359: if (norm) { IPNorm(ip,v,norm); }
360: if (lindep) *lindep = PETSC_FALSE;
361: } else {
362: switch (ip->orthog_type) {
363: case IP_ORTHOG_CGS:
364: IPPseudoOrthogonalizeCGS(ip,n,V,omega,v,H,norm,lindep);
365: break;
366: case IP_ORTHOG_MGS:
367: SETERRQ(PetscObjectComm((PetscObject)ip),PETSC_ERR_SUP,"Modified Gram-Schmidt not implemented for indefinite case");
368: break;
369: default:
370: SETERRQ(PetscObjectComm((PetscObject)ip),PETSC_ERR_ARG_WRONG,"Unknown orthogonalization type");
371: }
372: }
373: PetscLogEventEnd(IP_Orthogonalize,ip,0,0,0);
374: return(0);
375: }