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: }