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

Actual source code: qlanczos.c

      1: /*

      3:    SLEPc quadratic eigensolver: "qlanczos"

      5:    Method: Q-Lanczos

      7:    Algorithm:

      9:        Quadratic Lanczos with indefinite B-orthogonalization and
     10:        thick restart.

     12:    References:

     14:        [1] C. Campos and J.E. Roman, "A thick-restart Q-Lanczos method
     15:            for quadratic eigenvalue problems", in preparation, 2013.

     17:    Last update: Mar 2013

     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_QLanczos(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:   }
     69:   if (qep->problem_type!=QEP_HERMITIAN) SETERRQ(PetscObjectComm((PetscObject)qep),PETSC_ERR_SUP,"Requested method is only available for Hermitian problems");

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

     74:   DSSetType(qep->ds,DSGHIEP);
     75:   DSSetCompact(qep->ds,PETSC_TRUE);
     76:   DSAllocate(qep->ds,qep->ncv+1);
     77:   return(0);
     78: }

     83: /*
     84:   Compute B-norm of v=[v1;v2] whith  B=diag(-qep->T[0],qep->T[2])
     85: */
     86: PetscErrorCode QEPQLanczosNorm_private(QEP qep,Vec v1,Vec v2,PetscReal *norm,Vec vw)
     87: {
     89:   PetscScalar    p1,p2;
     90:
     92:   STMatMult(qep->st,0,v1,vw);
     93:   VecDot(vw,v1,&p1);
     94:   STMatMult(qep->st,2,v2,vw);
     95:   VecDot(vw,v2,&p2);
     96:   *norm = PetscRealPart(-p1+qep->sfactor*qep->sfactor*p2);
     97:   *norm = (*norm>0.0)?PetscSqrtReal(*norm):-PetscSqrtReal(-*norm);
     98:   return(0);
     99: }

    104: /*
    105:   Compute a step of Classical Gram-Schmidt orthogonalization
    106: */
    107: static PetscErrorCode QEPQLanczosCGS(QEP qep,PetscScalar *H,PetscBLASInt ldh,PetscReal *omega,PetscScalar *h,PetscBLASInt j,Vec *V,Vec t,Vec v,Vec w,PetscReal *onorm,PetscReal *norm,PetscScalar *work,Vec vw)
    108: {
    110:   PetscBLASInt   ione = 1,j_1 = j+1,i;
    111:   PetscScalar    dot,one = 1.0,zero = 0.0;

    114:   /* compute norm of [v;w] */
    115:   if (onorm) {
    116:     QEPQLanczosNorm_private(qep,v,w,onorm,vw);
    117:   }

    119:   /* orthogonalize: compute h */
    120:   STMatMult(qep->st,0,v,vw);
    121:   VecMDot(vw,j_1,V,h);
    122:   for (i=0;i<=j;i++) h[i] = -h[i];
    123:   STMatMult(qep->st,2,w,vw);
    124:   if (j>0) {
    125:     VecMDot(vw,j_1,V,work);
    126:     for (i=0;i<j_1;i++) work[i] *= qep->sfactor*qep->sfactor;
    127:     PetscStackCallBLAS("BLASgemv",BLASgemv_("C",&j_1,&j,&one,H,&ldh,work,&ione,&one,h,&ione));
    128:   }
    129:   VecDot(vw,t,&dot);
    130:   h[j] += dot*qep->sfactor*qep->sfactor;
    131:   /* apply inverse of signature */
    132:   for (i=0;i<=j;i++) h[i] /= omega[i];
    133:   /* orthogonalize: update v and w */
    134:   SlepcVecMAXPBY(v,1.0,-1.0,j_1,h,V);
    135:   if (j>0) {
    136:     PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&j_1,&j,&one,H,&ldh,h,&ione,&zero,work,&ione));
    137:     SlepcVecMAXPBY(w,1.0,-1.0,j_1,work,V);
    138:   }
    139:   VecAXPY(w,-h[j],t);
    140:   /* H pseudosymmetric, signature is not revert*/

    142:   /* compute norm of v and w */
    143:   if (norm) {
    144:     QEPQLanczosNorm_private(qep,v,w,norm,vw);
    145:   }
    146:   return(0);
    147: }

    151: /*
    152:   Compute a run of Q-Lanczos iterations
    153: */
    154: static PetscErrorCode QEPQLanczos(QEP qep,PetscScalar *H,PetscInt ldh,PetscReal *omega,Vec *V,PetscInt k,PetscInt *M,Vec v,Vec w,PetscBool *breakdown,PetscScalar *work,Vec *t_)
    155: {
    156:   PetscErrorCode     ierr;
    157:   PetscInt           i,j,m = *M,nwu = 0,l;
    158:   Vec                t = t_[0],u = t_[1];
    159:   IPOrthogRefineType refinement;
    160:   PetscReal          onorm,norm,eta;
    161:   PetscScalar        *c;

    164:   IPGetOrthogonalization(qep->ip,NULL,&refinement,&eta);
    165:   nwu += m+1;
    166:   c = work+nwu;

    168:   for (j=k;j<m;j++) {
    169:     /* apply operator */
    170:     VecCopy(w,t);
    171:     STMatMult(qep->st,0,v,u);
    172:     STMatMult(qep->st,1,t,w);
    173:     VecAXPY(u,qep->sfactor,w);
    174:     STMatSolve(qep->st,2,u,w);
    175:     VecScale(w,-1.0/(qep->sfactor*qep->sfactor));
    176:     VecCopy(t,v);

    178:     /* orthogonalize */
    179:     switch (refinement) {
    180:       case IP_ORTHOG_REFINE_NEVER:
    181:         QEPQLanczosCGS(qep,H,ldh,omega,H+ldh*j,j,V,t,v,w,NULL,&norm,work,u);
    182:         break;
    183:       case IP_ORTHOG_REFINE_ALWAYS:
    184:         QEPQLanczosCGS(qep,H,ldh,omega,H+ldh*j,j,V,t,v,w,NULL,NULL,work,u);
    185:         QEPQLanczosCGS(qep,H,ldh,omega,c,j,V,t,v,w,&onorm,&norm,work,u);
    186:         for (i=0;i<=j;i++) H[ldh*j+i] += c[i];
    187:         break;
    188:       case IP_ORTHOG_REFINE_IFNEEDED: /* -- */
    189:         QEPQLanczosCGS(qep,H,ldh,omega,H+ldh*j,j,V,t,v,w,&onorm,&norm,work,u);
    190:         /* ||q|| < eta ||h|| */
    191:         l = 1;
    192:         while (l<3 && PetscAbsReal(norm) < eta * PetscAbsReal(onorm)) {
    193:           l++;
    194:           onorm = norm;
    195:           QEPQLanczosCGS(qep,H,ldh,omega,c,j,V,t,v,w,NULL,&norm,work,u);
    196:           for (i=0;i<=j;i++) H[ldh*j+i] += c[i];
    197:         }
    198:         break;
    199:       default: SETERRQ(PetscObjectComm((PetscObject)qep),1,"Wrong value of ip->orth_ref");
    200:     }
    201:     if (breakdown) *breakdown = PETSC_FALSE; /* -- */
    202:     VecScale(v,1.0/norm);
    203:     VecScale(w,1.0/norm);

    205:     H[j+1+ldh*j] = norm;
    206:     omega[j+1] = (norm<0.0)?-1.0:1.0;
    207:     if (j<m-1) {
    208:       VecCopy(v,V[j+1]);
    209:     }
    210:   }
    211:   return(0);
    212: }

    216: PetscErrorCode QEPSolve_QLanczos(QEP qep)
    217: {
    219:   PetscInt       j,k,l,lwork,nv,ld,ti,t;
    220:   Vec            v=qep->work[0],w=qep->work[1],w_=qep->work[2]; /* v_=qep->work[3]; */
    221:   PetscScalar    *S,*Q,*work;
    222:   PetscReal      beta,norm,*omega,*a,*b,*r;
    223:   PetscBool      breakdown;

    226:   DSGetLeadingDimension(qep->ds,&ld);
    227:   lwork = 7*qep->ncv;  /* -- */
    228:   PetscMalloc(lwork*sizeof(PetscScalar),&work);

    230:   /* Get the starting Lanczos vector */
    231:   if (qep->nini==0) {
    232:     SlepcVecSetRandom(qep->V[0],qep->rand);
    233:   }
    234:   /* w is always a random vector */
    235:   SlepcVecSetRandom(w,qep->rand);
    236:   QEPQLanczosNorm_private(qep,qep->V[0],w,&norm,w_);
    237:   if (norm==0.0) SETERRQ(((PetscObject)qep)->comm,1,"Initial vector is zero or belongs to the deflation space");
    238:   VecScale(qep->V[0],1.0/norm);
    239:   VecScale(w,1.0/norm);
    240:   VecCopy(qep->V[0],v);
    241:   DSGetArrayReal(qep->ds,DS_MAT_D,&omega);
    242:   omega[0] = (norm > 0)?1.0:-1.0;
    243:   DSRestoreArrayReal(qep->ds,DS_MAT_D,&omega);

    245:   /* Restart loop */
    246:   l = 0;
    247:   while (qep->reason == QEP_CONVERGED_ITERATING) {
    248:     qep->its++;

    250:     /* Form projected problem matrix on S */
    251:     DSGetArray(qep->ds,DS_MAT_A,&S);
    252:     DSGetArrayReal(qep->ds,DS_MAT_T,&a);
    253:     b = a+ld;
    254:     r = b+ld;
    255:     DSGetArrayReal(qep->ds,DS_MAT_D,&omega);
    256:     PetscMemzero(S,ld*ld*sizeof(PetscScalar));
    257:     ti = qep->nconv+l;
    258:     for (j=0;j<ti;j++) {
    259:       S[j+j*ld] = a[j]*omega[j];
    260:       S[j+1+j*ld] = b[j]*omega[j+1];
    261:       S[j+(j+1)*ld] = b[j]*omega[j];
    262:     }
    263:     for (j=qep->nconv;j<ti;j++) {
    264:       S[ti+j*ld] = r[j]*omega[ti];
    265:     }

    267:     /* Compute an nv-step Lanczos factorization */
    268:     nv = PetscMin(qep->nconv+qep->mpd,qep->ncv);
    269:     QEPQLanczos(qep,S,ld,omega,qep->V,qep->nconv+l,&nv,v,w,&breakdown,work,&qep->work[2]);
    270:     for (j=ti;j<nv-1;j++) {
    271:       a[j] = PetscRealPart(S[j+j*ld]*omega[j]);
    272:       b[j] = PetscAbsReal(PetscRealPart(S[j+1+j*ld]));
    273:     }
    274:     a[nv-1] = PetscRealPart(S[nv-1+(nv-1)*ld]*omega[nv-1]);
    275:     beta = PetscAbsReal(PetscRealPart(S[nv+(nv-1)*ld]));
    276:     DSRestoreArray(qep->ds,DS_MAT_A,&S);
    277:     DSRestoreArrayReal(qep->ds,DS_MAT_T,&a);
    278:     DSRestoreArrayReal(qep->ds,DS_MAT_D,&omega);
    279:     DSSetDimensions(qep->ds,nv,0,qep->nconv,qep->nconv+l);
    280:     if (l==0) {
    281:       DSSetState(qep->ds,DS_STATE_INTERMEDIATE);
    282:     } else {
    283:       DSSetState(qep->ds,DS_STATE_RAW);
    284:     }

    286:     /* Solve projected problem */
    287:     DSSolve(qep->ds,qep->eigr,qep->eigi);
    288:     DSSort(qep->ds,qep->eigr,qep->eigi,NULL,NULL,NULL);

    290:     /* Check convergence */
    291:     DSGetDimensions(qep->ds,NULL,NULL,NULL,NULL,&t);
    292:     QEPKrylovConvergence(qep,PETSC_FALSE,qep->nconv,t-qep->nconv,nv,beta,&k);
    293:     if (qep->its >= qep->max_it) qep->reason = QEP_DIVERGED_ITS;
    294:     if (k >= qep->nev) qep->reason = QEP_CONVERGED_TOL;

    296:     /* Update l */
    297:     if (qep->reason != QEP_CONVERGED_ITERATING || breakdown) l = 0;
    298:     else {
    299:       l = PetscMax(1,(PetscInt)((nv-k)/2));
    300:       l = PetscMin(l,t);
    301:       DSGetArrayReal(qep->ds,DS_MAT_T,&a);
    302:       if (*(a+ld+k+l-1)!=0) {
    303:         if (k+l<nv-1) l = l+1;
    304:         else l = l-1;
    305:       }
    306:       DSRestoreArrayReal(qep->ds,DS_MAT_T,&a);
    307:     }

    309:     if (qep->reason == QEP_CONVERGED_ITERATING) {
    310:       if (breakdown) {
    311:         /* Stop if breakdown */
    312:         PetscInfo2(qep,"Breakdown Quadratic Lanczos method (it=%D norm=%G)\n",qep->its,beta);
    313:         qep->reason = QEP_DIVERGED_BREAKDOWN;
    314:       } else {
    315:         /* Prepare the Rayleigh quotient for restart */
    316:         DSGetArray(qep->ds,DS_MAT_Q,&Q);
    317:         DSGetArrayReal(qep->ds,DS_MAT_T,&a);
    318:         DSGetArrayReal(qep->ds,DS_MAT_D,&omega);
    319:         r = a + 2*ld;
    320:         for (j=k;j<k+l;j++) {
    321:           r[j] = PetscRealPart(Q[nv-1+j*ld]*beta);
    322:         }
    323:         b = a+ld;
    324:         b[k+l-1] = r[k+l-1];
    325:         omega[k+l] = omega[nv];
    326:         DSRestoreArray(qep->ds,DS_MAT_Q,&Q);
    327:         DSRestoreArrayReal(qep->ds,DS_MAT_T,&a);
    328:         DSRestoreArrayReal(qep->ds,DS_MAT_D,&omega);
    329:       }
    330:     }
    331:     /* Update the corresponding vectors V(:,idx) = V*Q(:,idx) */
    332:     DSGetArray(qep->ds,DS_MAT_Q,&Q);
    333:     SlepcUpdateVectors(nv,qep->V,qep->nconv,k+l,Q,ld,PETSC_FALSE);
    334:     DSRestoreArray(qep->ds,DS_MAT_Q,&Q);
    335:
    336:     /* Append v to V*/
    337:     if (qep->reason == QEP_CONVERGED_ITERATING) {
    338:       VecCopy(v,qep->V[k+l]);
    339:     }
    340:     qep->nconv = k;
    341:     QEPMonitor(qep,qep->its,qep->nconv,qep->eigr,qep->eigi,qep->errest,nv);
    342:   }

    344:   for (j=0;j<qep->nconv;j++) {
    345:     qep->eigr[j] *= qep->sfactor;
    346:     qep->eigi[j] *= qep->sfactor;
    347:   }

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

    354:   /* Compute eigenvectors */
    355:   if (qep->nconv > 0) {
    356:     QEPComputeVectors_Schur(qep);
    357:   }
    358:   PetscFree(work);
    359:   return(0);
    360: }

    364: PETSC_EXTERN PetscErrorCode QEPCreate_QLanczos(QEP qep)
    365: {
    367:   qep->ops->solve                = QEPSolve_QLanczos;
    368:   qep->ops->setup                = QEPSetUp_QLanczos;
    369:   qep->ops->reset                = QEPReset_Default;
    370:   return(0);
    371: }