Date: 2013-09-02T10:07:28+00:00

Actual source code: qarnoldi.c

      1: /*

      3:    SLEPc quadratic eigensolver: "qarnoldi"

      5:    Method: Q-Arnoldi

      7:    Algorithm:

      9:        Quadratic Arnoldi with Krylov-Schur type restart.

     11:    References:

     13:        [1] K. Meerbergen, "The Quadratic Arnoldi method for the solution
     14:            of the quadratic eigenvalue problem", SIAM J. Matrix Anal.
     15:            Appl. 30(4):1462-1482, 2008.

     17:    Last update: Nov 2012

     19:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
     20:    SLEPc - Scalable Library for Eigenvalue Problem Computations
     21:    Copyright (c) 2002-2013, Universitat Politecnica de Valencia, Spain

     23:    This file is part of SLEPc.

     25:    SLEPc is free software: you can redistribute it and/or modify it under  the
     26:    terms of version 3 of the GNU Lesser General Public License as published by
     27:    the Free Software Foundation.

     29:    SLEPc  is  distributed in the hope that it will be useful, but WITHOUT  ANY
     30:    WARRANTY;  without even the implied warranty of MERCHANTABILITY or  FITNESS
     31:    FOR  A  PARTICULAR PURPOSE. See the GNU Lesser General Public  License  for
     32:    more details.

     34:    You  should have received a copy of the GNU Lesser General  Public  License
     35:    along with SLEPc. If not, see <http://www.gnu.org/licenses/>.
     36:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
     37: */

     39: #include <slepc-private/qepimpl.h>         /*I "slepcqep.h" I*/
     40: #include <petscblaslapack.h>

     44: PetscErrorCode QEPSetUp_QArnoldi(QEP qep)
     45: {
     47:   PetscBool      sinv;

     50:   if (qep->ncv) { /* ncv set */
     51:     if (qep->ncv<qep->nev) SETERRQ(PetscObjectComm((PetscObject)qep),1,"The value of ncv must be at least nev");
     52:   } else if (qep->mpd) { /* mpd set */
     53:     qep->ncv = PetscMin(qep->n,qep->nev+qep->mpd);
     54:   } else { /* neither set: defaults depend on nev being small or large */
     55:     if (qep->nev<500) qep->ncv = PetscMin(qep->n,PetscMax(2*qep->nev,qep->nev+15));
     56:     else {
     57:       qep->mpd = 500;
     58:       qep->ncv = PetscMin(qep->n,qep->nev+qep->mpd);
     59:     }
     60:   }
     61:   if (!qep->mpd) qep->mpd = qep->ncv;
     62:   if (qep->ncv>qep->nev+qep->mpd) SETERRQ(PetscObjectComm((PetscObject)qep),1,"The value of ncv must not be larger than nev+mpd");
     63:   if (!qep->max_it) qep->max_it = PetscMax(100,2*qep->n/qep->ncv);
     64:   if (!qep->which) {
     65:     PetscObjectTypeCompare((PetscObject)qep->st,STSINVERT,&sinv);
     66:     if (sinv) qep->which = QEP_TARGET_MAGNITUDE;
     67:     else qep->which = QEP_LARGEST_MAGNITUDE;
     68:   }

     70:   QEPAllocateSolution(qep);
     71:   QEPSetWorkVecs(qep,4);

     73:   DSSetType(qep->ds,DSNHEP);
     74:   DSSetExtraRow(qep->ds,PETSC_TRUE);
     75:   DSAllocate(qep->ds,qep->ncv+1);
     76:   return(0);
     77: }

     81: /*
     82:   Compute a step of Classical Gram-Schmidt orthogonalization
     83: */
     84: static 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)
     85: {
     87:   PetscBLASInt   ione = 1,j_1 = j+1;
     88:   PetscReal      x,y;
     89:   PetscScalar    dot,one = 1.0,zero = 0.0;

     92:   /* compute norm of v and w */
     93:   if (onorm) {
     94:     VecNorm(v,NORM_2,&x);
     95:     VecNorm(w,NORM_2,&y);
     96:     *onorm = PetscSqrtReal(x*x+y*y);
     97:   }

     99:   /* orthogonalize: compute h */
    100:   VecMDot(v,j_1,V,h);
    101:   VecMDot(w,j_1,V,work);
    102:   if (j>0)
    103:     PetscStackCallBLAS("BLASgemv",BLASgemv_("C",&j_1,&j,&one,H,&ldh,work,&ione,&one,h,&ione));
    104:   VecDot(w,t,&dot);
    105:   h[j] += dot;

    107:   /* orthogonalize: update v and w */
    108:   SlepcVecMAXPBY(v,1.0,-1.0,j_1,h,V);
    109:   if (j>0) {
    110:     PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&j_1,&j,&one,H,&ldh,h,&ione,&zero,work,&ione));
    111:     SlepcVecMAXPBY(w,1.0,-1.0,j_1,work,V);
    112:   }
    113:   VecAXPY(w,-h[j],t);

    115:   /* compute norm of v and w */
    116:   if (norm) {
    117:     VecNorm(v,NORM_2,&x);
    118:     VecNorm(w,NORM_2,&y);
    119:     *norm = PetscSqrtReal(x*x+y*y);
    120:   }
    121:   return(0);
    122: }

    126: /*
    127:   Compute a run of Q-Arnoldi iterations
    128: */
    129: static PetscErrorCode QEPQArnoldi(QEP qep,PetscScalar *H,PetscInt ldh,Vec *V,PetscInt k,PetscInt *M,Vec v,Vec w,PetscReal *beta,PetscBool *breakdown,PetscScalar *work)
    130: {
    131:   PetscErrorCode     ierr;
    132:   PetscInt           i,j,l,m = *M;
    133:   Vec                t = qep->work[2],u = qep->work[3];
    134:   IPOrthogRefineType refinement;
    135:   PetscReal          norm,onorm,eta;
    136:   PetscScalar        *c = work + m;

    139:   IPGetOrthogonalization(qep->ip,NULL,&refinement,&eta);
    140:   VecCopy(v,qep->V[k]);

    142:   for (j=k;j<m;j++) {
    143:     /* apply operator */
    144:     VecCopy(w,t);
    145:     STMatMult(qep->st,0,v,u);
    146:     STMatMult(qep->st,1,t,w);
    147:     VecAXPY(u,qep->sfactor,w);
    148:     STMatSolve(qep->st,2,u,w);
    149:     VecScale(w,-1.0/(qep->sfactor*qep->sfactor));
    150:     VecCopy(t,v);

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

    183:     H[j+1+ldh*j] = norm;
    184:     if (j<m-1) {
    185:       VecCopy(v,V[j+1]);
    186:     }
    187:   }
    188:   *beta = norm;
    189:   return(0);
    190: }

    194: PetscErrorCode QEPSolve_QArnoldi(QEP qep)
    195: {
    197:   PetscInt       j,k,l,lwork,nv,ld,newn;
    198:   Vec            v=qep->work[0],w=qep->work[1],v_=qep->work[2],w_=qep->work[3];
    199:   PetscScalar    *S,*Q,*work,r,s;
    200:   PetscReal      beta=0.0,norm,x,y,t;
    201:   PetscBool      breakdown=PETSC_FALSE,issinv;

    204:   DSGetLeadingDimension(qep->ds,&ld);
    205:   lwork = 7*qep->ncv;
    206:   PetscMalloc(lwork*sizeof(PetscScalar),&work);

    208:   /* Get the starting Arnoldi vector */
    209:   if (qep->nini>0) {
    210:     VecCopy(qep->V[0],v);
    211:   } else {
    212:     SlepcVecSetRandom(v,qep->rand);
    213:   }
    214:   /* w is always a random vector */
    215:   SlepcVecSetRandom(w,qep->rand);
    216:   VecNorm(v,NORM_2,&x);
    217:   VecNorm(w,NORM_2,&y);
    218:   norm = PetscSqrtReal(x*x+y*y);
    219:   VecScale(v,1.0/norm);
    220:   VecScale(w,1.0/norm);

    222:   /* Compute scaling factor if not set by user */
    223:   PetscObjectTypeCompare((PetscObject)qep->st,STSINVERT,&issinv);
    224:   if (issinv && !qep->sfactor_set) {
    225:     STMatMult(qep->st,1,w,w_);
    226:     STMatMult(qep->st,0,v,v_);
    227:     VecAXPY(v_,1.0,w_);
    228:     STMatSolve(qep->st,2,v_,w_);
    229:     VecScale(w_,-1.0);
    230:     VecCopy(w,v_);
    231:     VecDot(v_,v,&r);
    232:     VecDot(w_,w,&s);
    233:     t = PetscAbsScalar(r+s);
    234:     qep->sfactor = 1.0;
    235:     while (t > 1.0) {
    236:       qep->sfactor *=10.0;
    237:       t /= 10.0;
    238:     }
    239:   }
    240:   /* Restart loop */
    241:   l = 0;
    242:   while (qep->reason == QEP_CONVERGED_ITERATING) {
    243:     qep->its++;

    245:     /* Compute an nv-step Arnoldi factorization */
    246:     nv = PetscMin(qep->nconv+qep->mpd,qep->ncv);
    247:     DSGetArray(qep->ds,DS_MAT_A,&S);
    248:     QEPQArnoldi(qep,S,ld,qep->V,qep->nconv+l,&nv,v,w,&beta,&breakdown,work);
    249:     DSRestoreArray(qep->ds,DS_MAT_A,&S);
    250:     DSSetDimensions(qep->ds,nv,0,qep->nconv,qep->nconv+l);
    251:     if (l==0) {
    252:       DSSetState(qep->ds,DS_STATE_INTERMEDIATE);
    253:     } else {
    254:       DSSetState(qep->ds,DS_STATE_RAW);
    255:     }

    257:     /* Solve projected problem */
    258:     DSSolve(qep->ds,qep->eigr,qep->eigi);
    259:     DSSort(qep->ds,qep->eigr,qep->eigi,NULL,NULL,NULL);
    260:     DSUpdateExtraRow(qep->ds);

    262:     /* Check convergence */
    263:     QEPKrylovConvergence(qep,PETSC_FALSE,qep->nconv,nv-qep->nconv,nv,beta,&k);
    264:     if (qep->its >= qep->max_it) qep->reason = QEP_DIVERGED_ITS;
    265:     if (k >= qep->nev) qep->reason = QEP_CONVERGED_TOL;

    267:     /* Update l */
    268:     if (qep->reason != QEP_CONVERGED_ITERATING || breakdown) l = 0;
    269:     else l = (nv-k)/2;

    271:     if (qep->reason == QEP_CONVERGED_ITERATING) {
    272:       if (breakdown) {
    273:         /* Stop if breakdown */
    274:         PetscInfo2(qep,"Breakdown Quadratic Arnoldi method (it=%D norm=%G)\n",qep->its,beta);
    275:         qep->reason = QEP_DIVERGED_BREAKDOWN;
    276:       } else {
    277:         /* Prepare the Rayleigh quotient for restart */
    278:         DSTruncate(qep->ds,k+l);
    279:         DSGetDimensions(qep->ds,&newn,NULL,NULL,NULL,NULL);
    280:         l = newn-k;
    281:       }
    282:     }
    283:     /* Update the corresponding vectors V(:,idx) = V*Q(:,idx) */
    284:     DSGetArray(qep->ds,DS_MAT_Q,&Q);
    285:     SlepcUpdateVectors(nv,qep->V,qep->nconv,k+l,Q,ld,PETSC_FALSE);
    286:     DSRestoreArray(qep->ds,DS_MAT_Q,&Q);

    288:     qep->nconv = k;
    289:     QEPMonitor(qep,qep->its,qep->nconv,qep->eigr,qep->eigi,qep->errest,nv);
    290:   }

    292:   for (j=0;j<qep->nconv;j++) {
    293:     qep->eigr[j] *= qep->sfactor;
    294:     qep->eigi[j] *= qep->sfactor;
    295:   }

    297:   /* truncate Schur decomposition and change the state to raw so that
    298:      DSVectors() computes eigenvectors from scratch */
    299:   DSSetDimensions(qep->ds,qep->nconv,0,0,0);
    300:   DSSetState(qep->ds,DS_STATE_RAW);

    302:   /* Compute eigenvectors */
    303:   if (qep->nconv > 0) {
    304:     QEPComputeVectors_Schur(qep);
    305:   }
    306:   PetscFree(work);
    307:   return(0);
    308: }

    312: PETSC_EXTERN PetscErrorCode QEPCreate_QArnoldi(QEP qep)
    313: {
    315:   qep->ops->solve                = QEPSolve_QArnoldi;
    316:   qep->ops->setup                = QEPSetUp_QArnoldi;
    317:   qep->ops->reset                = QEPReset_Default;
    318:   return(0);
    319: }