Actual source code: qarnoldi.c

  1: /*                       

  3:    Q-Arnoldi method for quadratic eigenproblems.

  5:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  6:    SLEPc - Scalable Library for Eigenvalue Problem Computations
  7:    Copyright (c) 2002-2011, Universitat Politecnica de Valencia, Spain

  9:    This file is part of SLEPc.
 10:       
 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 <private/qepimpl.h>         /*I "slepcqep.h" I*/
 26: #include <petscblaslapack.h>

 28: typedef struct {
 29:   KSP ksp;
 30: } QEP_QARNOLDI;

 34: PetscErrorCode QEPSetUp_QArnoldi(QEP qep)
 35: {
 37:   QEP_QARNOLDI   *ctx = (QEP_QARNOLDI*)qep->data;
 38: 
 40:   if (qep->ncv) { /* ncv set */
 41:     if (qep->ncv<qep->nev) SETERRQ(((PetscObject)qep)->comm,1,"The value of ncv must be at least nev");
 42:   }
 43:   else if (qep->mpd) { /* mpd set */
 44:     qep->ncv = PetscMin(qep->n,qep->nev+qep->mpd);
 45:   }
 46:   else { /* neither set: defaults depend on nev being small or large */
 47:     if (qep->nev<500) qep->ncv = PetscMin(qep->n,PetscMax(2*qep->nev,qep->nev+15));
 48:     else { qep->mpd = 500; qep->ncv = PetscMin(qep->n,qep->nev+qep->mpd); }
 49:   }
 50:   if (!qep->mpd) qep->mpd = qep->ncv;
 51:   if (qep->ncv>qep->nev+qep->mpd) SETERRQ(((PetscObject)qep)->comm,1,"The value of ncv must not be larger than nev+mpd");
 52:   if (!qep->max_it) qep->max_it = PetscMax(100,2*qep->n/qep->ncv);
 53:   if (!qep->which) qep->which = QEP_LARGEST_MAGNITUDE;
 54:   if (qep->problem_type != QEP_GENERAL)
 55:     SETERRQ(((PetscObject)qep)->comm,1,"Wrong value of qep->problem_type");

 57:   QEPAllocateSolution(qep);
 58:   PetscFree(qep->T);
 59:   PetscMalloc(qep->ncv*qep->ncv*sizeof(PetscScalar),&qep->T);
 60:   QEPDefaultGetWork(qep,4);

 62:   KSPSetOperators(ctx->ksp,qep->M,qep->M,DIFFERENT_NONZERO_PATTERN);
 63:   KSPSetUp(ctx->ksp);
 64:   return(0);
 65: }

 69: /*
 70:   Compute a step of Classical Gram-Schmidt orthogonalization 
 71: */
 72: PetscErrorCode QEPQArnoldiCGS(QEP qep,PetscScalar *H,PetscBLASInt ldh,PetscScalar *h,PetscBLASInt j,Vec *V,Vec t,Vec v,Vec w,PetscReal *onorm,PetscReal *norm,PetscScalar *work)
 73: {
 75:   PetscBLASInt   ione = 1,j_1 = j+1;
 76:   PetscReal      x,y;
 77:   PetscScalar    dot,one = 1.0,zero = 0.0;

 80:   /* compute norm of v and w */
 81:   if (onorm) {
 82:     VecNorm(v,NORM_2,&x);
 83:     VecNorm(w,NORM_2,&y);
 84:     *onorm = PetscSqrtReal(x*x+y*y);
 85:   }

 87:   /* orthogonalize: compute h */
 88:   VecMDot(v,j_1,V,h);
 89:   VecMDot(w,j_1,V,work);
 90:   if (j>0)
 91:     BLASgemv_("C",&j_1,&j,&one,H,&ldh,work,&ione,&one,h,&ione);
 92:   VecDot(t,w,&dot);
 93:   h[j] += dot;

 95:   /* orthogonalize: update v and w */
 96:   SlepcVecMAXPBY(v,1.0,-1.0,j_1,h,V);
 97:   if (j>0) {
 98:     BLASgemv_("N",&j_1,&j,&one,H,&ldh,h,&ione,&zero,work,&ione);
 99:     SlepcVecMAXPBY(w,1.0,-1.0,j_1,work,V);
100:   }
101:   VecAXPY(w,-h[j],t);
102: 
103:   /* compute norm of v and w */
104:   if (norm) {
105:     VecNorm(v,NORM_2,&x);
106:     VecNorm(w,NORM_2,&y);
107:     *norm = PetscSqrtReal(x*x+y*y);
108:   }
109:   return(0);
110: }

114: /*
115:   Compute a run of Q-Arnoldi iterations
116: */
117: PetscErrorCode QEPQArnoldi(QEP qep,PetscScalar *H,PetscInt ldh,Vec *V,PetscInt k,PetscInt *M,Vec v,Vec w,PetscReal *beta,PetscBool *breakdown,PetscScalar *work)
118: {
119:   PetscErrorCode     ierr;
120:   PetscInt           i,j,l,m = *M;
121:   QEP_QARNOLDI       *ctx = (QEP_QARNOLDI*)qep->data;
122:   Vec                t = qep->work[2],u = qep->work[3];
123:   IPOrthogRefineType refinement;
124:   PetscReal          norm,onorm,eta;
125:   PetscScalar        *c = work + m;

128:   IPGetOrthogonalization(qep->ip,PETSC_NULL,&refinement,&eta);
129:   VecCopy(v,qep->V[k]);
130: 
131:   for (j=k;j<m;j++) {
132:     /* apply operator */
133:     VecCopy(w,t);
134:     MatMult(qep->K,v,u);
135:     MatMult(qep->C,t,w);
136:     VecAXPY(u,qep->sfactor,w);
137:     KSPSolve(ctx->ksp,u,w);
138:     VecScale(w,-1.0/(qep->sfactor*qep->sfactor));
139:     VecCopy(t,v);

141:     /* orthogonalize */
142:     switch (refinement) {
143:       case IP_ORTHOG_REFINE_NEVER:
144:         QEPQArnoldiCGS(qep,H,ldh,H+ldh*j,j,V,t,v,w,PETSC_NULL,&norm,work);
145:         *breakdown = PETSC_FALSE;
146:         break;
147:       case IP_ORTHOG_REFINE_ALWAYS:
148:         QEPQArnoldiCGS(qep,H,ldh,H+ldh*j,j,V,t,v,w,PETSC_NULL,PETSC_NULL,work);
149:         QEPQArnoldiCGS(qep,H,ldh,c,j,V,t,v,w,&onorm,&norm,work);
150:         for (i=0;i<j;i++) H[ldh*j+i] += c[i];
151:         if (norm < eta * onorm) *breakdown = PETSC_TRUE;
152:         else *breakdown = PETSC_FALSE;
153:         break;
154:       case IP_ORTHOG_REFINE_IFNEEDED:
155:         QEPQArnoldiCGS(qep,H,ldh,H+ldh*j,j,V,t,v,w,&onorm,&norm,work);
156:         /* ||q|| < eta ||h|| */
157:         l = 1;
158:         while (l<3 && norm < eta * onorm) {
159:           l++;
160:           onorm = norm;
161:           QEPQArnoldiCGS(qep,H,ldh,c,j,V,t,v,w,PETSC_NULL,&norm,work);
162:           for (i=0;i<j;i++) H[ldh*j+i] += c[i];
163:         }
164:         if (norm < eta * onorm) *breakdown = PETSC_TRUE;
165:         else *breakdown = PETSC_FALSE;
166:         break;
167:       default: SETERRQ(((PetscObject)qep)->comm,1,"Wrong value of ip->orth_ref");
168:     }
169:     VecScale(v,1.0/norm);
170:     VecScale(w,1.0/norm);
171: 
172:     if (j<m-1) {
173:       H[j+1+ldh*j] = norm;
174:       VecCopy(v,V[j+1]);
175:     }
176:   }
177:   *beta = norm;
178:   return(0);
179: }

183: /*
184:    QEPProjectedKSNonsym - Solves the projected eigenproblem in the Krylov-Schur
185:    method (non-symmetric case).

187:    On input:
188:      l is the number of vectors kept in previous restart (0 means first restart)
189:      S is the projected matrix (leading dimension is lds)

191:    On output:
192:      S has (real) Schur form with diagonal blocks sorted appropriately
193:      Q contains the corresponding Schur vectors (order n, leading dimension n)
194: */
195: PetscErrorCode QEPProjectedKSNonsym(QEP qep,PetscInt l,PetscScalar *S,PetscInt lds,PetscScalar *Q,PetscInt n)
196: {
198:   PetscInt       i;

201:   if (l==0) {
202:     PetscMemzero(Q,n*n*sizeof(PetscScalar));
203:     for (i=0;i<n;i++)
204:       Q[i*(n+1)] = 1.0;
205:   } else {
206:     /* Reduce S to Hessenberg form, S <- Q S Q' */
207:     EPSDenseHessenberg(n,qep->nconv,S,lds,Q);
208:   }
209:   /* Reduce S to (quasi-)triangular form, S <- Q S Q' */
210:   EPSDenseSchur(n,qep->nconv,S,lds,Q,qep->eigr,qep->eigi);
211:   /* Sort the remaining columns of the Schur form */
212:   QEPSortDenseSchur(qep,n,qep->nconv,S,lds,Q,qep->eigr,qep->eigi);
213:   return(0);
214: }

218: PetscErrorCode QEPSolve_QArnoldi(QEP qep)
219: {
221:   PetscInt       i,j,k,l,lwork,nv;
222:   Vec            v=qep->work[0],w=qep->work[1];
223:   PetscScalar    *S=qep->T,*Q,*work;
224:   PetscReal      beta,norm,x,y;
225:   PetscBool      breakdown;

228:   PetscMemzero(S,qep->ncv*qep->ncv*sizeof(PetscScalar));
229:   PetscMalloc(qep->ncv*qep->ncv*sizeof(PetscScalar),&Q);
230:   lwork = 7*qep->ncv;
231:   PetscMalloc(lwork*sizeof(PetscScalar),&work);

233:   /* Get the starting Arnoldi vector */
234:   if (qep->nini>0) {
235:     VecCopy(qep->V[0],v);
236:   } else {
237:     SlepcVecSetRandom(v,qep->rand);
238:   }
239:   /* w is always a random vector */
240:   SlepcVecSetRandom(w,qep->rand);
241:   VecNorm(v,NORM_2,&x);
242:   VecNorm(w,NORM_2,&y);
243:   norm = PetscSqrtReal(x*x+y*y);
244:   VecScale(v,1.0/norm);
245:   VecScale(w,1.0/norm);
246: 
247:   /* Restart loop */
248:   l = 0;
249:   while (qep->reason == QEP_CONVERGED_ITERATING) {
250:     qep->its++;

252:     /* Compute an nv-step Arnoldi factorization */
253:     nv = PetscMin(qep->nconv+qep->mpd,qep->ncv);
254:     QEPQArnoldi(qep,S,qep->ncv,qep->V,qep->nconv+l,&nv,v,w,&beta,&breakdown,work);

256:     /* Solve projected problem */
257:     QEPProjectedKSNonsym(qep,l,S,qep->ncv,Q,nv);

259:     /* Check convergence */
260:     QEPKrylovConvergence(qep,qep->nconv,nv-qep->nconv,S,qep->ncv,Q,nv,beta,&k,work);
261:     if (qep->its >= qep->max_it) qep->reason = QEP_DIVERGED_ITS;
262:     if (k >= qep->nev) qep->reason = QEP_CONVERGED_TOL;
263: 
264:     /* Update l */
265:     if (qep->reason != QEP_CONVERGED_ITERATING || breakdown) l = 0;
266:     else {
267:       l = (nv-k)/2;
268: #if !defined(PETSC_USE_COMPLEX)
269:       if (S[(k+l-1)*(qep->ncv+1)+1] != 0.0) {
270:         if (k+l<nv-1) l = l+1;
271:         else l = l-1;
272:       }
273: #endif
274:     }

276:     if (qep->reason == QEP_CONVERGED_ITERATING) {
277:       if (breakdown) {
278:         /* Stop if breakdown */
279:         PetscInfo2(qep,"Breakdown Quadratic Arnoldi method (it=%D norm=%G)\n",qep->its,beta);
280:         qep->reason = QEP_DIVERGED_BREAKDOWN;
281:       } else {
282:         /* Prepare the Rayleigh quotient for restart */
283:         for (i=k;i<k+l;i++) {
284:           S[i*qep->ncv+k+l] = Q[(i+1)*nv-1]*beta;
285:         }
286:       }
287:     }
288:     /* Update the corresponding vectors V(:,idx) = V*Q(:,idx) */
289:     SlepcUpdateVectors(nv,qep->V,qep->nconv,k+l,Q,nv,PETSC_FALSE);

291:     qep->nconv = k;
292:     QEPMonitor(qep,qep->its,qep->nconv,qep->eigr,qep->eigi,qep->errest,nv);
293:   }

295:   for (j=0;j<qep->nconv;j++) {
296:     qep->eigr[j] *= qep->sfactor;
297:     qep->eigi[j] *= qep->sfactor;
298:   }

300:   /* Compute eigenvectors */
301:   if (qep->nconv > 0) {
302:     QEPComputeVectors_Schur(qep);
303:   }

305:   PetscFree(Q);
306:   PetscFree(work);
307:   return(0);
308: }

312: PetscErrorCode QEPSetFromOptions_QArnoldi(QEP qep)
313: {
315:   QEP_QARNOLDI   *ctx = (QEP_QARNOLDI*)qep->data;
316: 
318:   KSPSetFromOptions(ctx->ksp);
319:   return(0);
320: }

324: PetscErrorCode QEPView_QArnoldi(QEP qep,PetscViewer viewer)
325: {
327:   QEP_QARNOLDI   *ctx = (QEP_QARNOLDI*)qep->data;

330:   PetscViewerASCIIPushTab(viewer);
331:   KSPView(ctx->ksp,viewer);
332:   PetscViewerASCIIPopTab(viewer);
333:   return(0);
334: }

338: PetscErrorCode QEPReset_QArnoldi(QEP qep)
339: {
341:   QEP_QARNOLDI   *ctx = (QEP_QARNOLDI*)qep->data;

344:   PetscFree(qep->T);
345:   KSPReset(ctx->ksp);
346:   QEPDefaultFreeWork(qep);
347:   QEPFreeSolution(qep);
348:   return(0);
349: }

353: PetscErrorCode QEPDestroy_QArnoldi(QEP qep)
354: {
356:   QEP_QARNOLDI   *ctx = (QEP_QARNOLDI*)qep->data;

359:   KSPDestroy(&ctx->ksp);
360:   PetscFree(qep->data);
361:   return(0);
362: }

364: EXTERN_C_BEGIN
367: PetscErrorCode QEPCreate_QArnoldi(QEP qep)
368: {
370:   QEP_QARNOLDI   *ctx;

373:   PetscNewLog(qep,QEP_QARNOLDI,&ctx);
374:   qep->data                      = ctx;
375:   qep->ops->solve                = QEPSolve_QArnoldi;
376:   qep->ops->setup                = QEPSetUp_QArnoldi;
377:   qep->ops->setfromoptions       = QEPSetFromOptions_QArnoldi;
378:   qep->ops->destroy              = QEPDestroy_QArnoldi;
379:   qep->ops->reset                = QEPReset_QArnoldi;
380:   qep->ops->view                 = QEPView_QArnoldi;
381:   KSPCreate(((PetscObject)qep)->comm,&ctx->ksp);
382:   KSPSetOptionsPrefix(ctx->ksp,((PetscObject)qep)->prefix);
383:   KSPAppendOptionsPrefix(ctx->ksp,"qep_");
384:   PetscObjectIncrementTabLevel((PetscObject)ctx->ksp,(PetscObject)qep,1);
385:   PetscLogObjectParent(qep,ctx->ksp);
386:   return(0);
387: }
388: EXTERN_C_END