Date: 2017-05-17T08:26:56+00:00

Actual source code: ptoar.c
slepc-3.7.4 2017-05-17
Report Typos and Errors

      1: /*

      3:    SLEPc polynomial eigensolver: "toar"

      5:    Method: TOAR

      7:    Algorithm:

      9:        Two-Level Orthogonal Arnoldi.

     11:    References:

     13:        [1] Y. Su, J. Zhang and Z. Bai, "A compact Arnoldi algorithm for
     14:            polynomial eigenvalue problems", talk presented at RANMEP 2008.

     16:        [2] C. Campos and J.E. Roman, "Parallel Krylov solvers for the
     17:            polynomial eigenvalue problem in SLEPc", SIAM J. Sci. Comput.
     18:            to appear, 2016.

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

     24:    This file is part of SLEPc.

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

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

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

     40: #include <slepc/private/pepimpl.h>    /*I "slepcpep.h" I*/
     41:  #include ../src/pep/impls/krylov/pepkrylov.h
     42: #include <slepcblaslapack.h>

     44: static PetscBool  cited = PETSC_FALSE;
     45: static const char citation[] =
     46:   "@Article{slepc-pep,\n"
     47:   "   author = \"C. Campos and J. E. Roman\",\n"
     48:   "   title = \"Parallel {Krylov} solvers for the polynomial eigenvalue problem in {SLEPc}\",\n"
     49:   "   journal = \"{SIAM} J. Sci. Comput.\",\n"
     50:   "   volume = \"to appear\",\n"
     51:   "   number = \"\",\n"
     52:   "   pages = \"\",\n"
     53:   "   year = \"2016,\"\n"
     54:   "   doi = \"http://dx.doi.org/10.xxxx/yyyy\"\n"
     55:   "}\n";

     59: /*
     60:   Norm of [sp;sq]
     61: */
     62: static PetscErrorCode PEPTOARSNorm2(PetscInt n,PetscScalar *S,PetscReal *norm)
     63: {
     65:   PetscBLASInt   n_,one=1;

     68:   PetscBLASIntCast(n,&n_);
     69:   *norm = BLASnrm2_(&n_,S,&one);
     70:   return(0);
     71: }

     75: PetscErrorCode PEPSetUp_TOAR(PEP pep)
     76: {
     78:   PEP_TOAR       *ctx = (PEP_TOAR*)pep->data;
     79:   PetscBool      shift,sinv,flg,lindep;
     80:   PetscInt       i,lds,deg=pep->nmat-1,j;
     81:   PetscReal      norm;

     84:   pep->lineariz = PETSC_TRUE;
     85:   PEPSetDimensions_Default(pep,pep->nev,&pep->ncv,&pep->mpd);
     86:   if (!ctx->lock && pep->mpd<pep->ncv) SETERRQ(PetscObjectComm((PetscObject)pep),PETSC_ERR_SUP,"Should not use mpd parameter in non-locking variant");
     87:   if (!pep->max_it) pep->max_it = PetscMax(100,2*(pep->nmat-1)*pep->n/pep->ncv);
     88:   /* Set STSHIFT as the default ST */
     89:   if (!((PetscObject)pep->st)->type_name) {
     90:     STSetType(pep->st,STSHIFT);
     91:   }
     92:   PetscObjectTypeCompare((PetscObject)pep->st,STSHIFT,&shift);
     93:   PetscObjectTypeCompare((PetscObject)pep->st,STSINVERT,&sinv);
     94:   if (!shift && !sinv) SETERRQ(PetscObjectComm((PetscObject)pep),PETSC_ERR_SUP,"Only STSHIFT and STSINVERT spectral transformations can be used");
     95:   if (!pep->which) {
     96:     if (sinv) pep->which = PEP_TARGET_MAGNITUDE;
     97:     else pep->which = PEP_LARGEST_MAGNITUDE;
     98:   }
     99:   if (pep->problem_type!=PEP_GENERAL) {
    100:     PetscInfo(pep,"Problem type ignored, performing a non-symmetric linearization\n");
    101:   }

    103:   if (!ctx->keep) ctx->keep = 0.5;

    105:   PEPAllocateSolution(pep,pep->nmat-1);
    106:   PEPSetWorkVecs(pep,3);
    107:   DSSetType(pep->ds,DSNHEP);
    108:   DSSetExtraRow(pep->ds,PETSC_TRUE);
    109:   DSAllocate(pep->ds,pep->ncv+1);

    111:   PEPBasisCoefficients(pep,pep->pbc);
    112:   STGetTransform(pep->st,&flg);
    113:   if (!flg) {
    114:     PetscMalloc1(pep->nmat,&pep->solvematcoeffs);
    115:     if (sinv) {
    116:       PEPEvaluateBasis(pep,pep->target,0,pep->solvematcoeffs,NULL);
    117:     } else {
    118:       for (i=0;i<pep->nmat-1;i++) pep->solvematcoeffs[i] = 0.0;
    119:       pep->solvematcoeffs[pep->nmat-1] = 1.0;
    120:     }
    121:   }
    122:   ctx->ld = pep->ncv+(pep->nmat-1);   /* number of rows of each fragment of S */
    123:   lds = (pep->nmat-1)*ctx->ld;
    124:   PetscCalloc1(lds*ctx->ld,&ctx->S);

    126:   /* process starting vector */
    127:   ctx->nq = 0;
    128:   for (i=0;i<deg;i++) {
    129:     if (pep->nini>-deg) {
    130:       BVSetRandomColumn(pep->V,ctx->nq);
    131:     } else {
    132:       BVInsertVec(pep->V,ctx->nq,pep->IS[i]);
    133:     }
    134:     BVOrthogonalizeColumn(pep->V,ctx->nq,ctx->S+i*ctx->ld,&norm,&lindep);
    135:     if (!lindep) {
    136:       BVScaleColumn(pep->V,ctx->nq,1.0/norm);
    137:       ctx->S[ctx->nq+i*ctx->ld] = norm;
    138:       ctx->nq++;
    139:     }
    140:   }
    141:   if (ctx->nq==0) SETERRQ(PetscObjectComm((PetscObject)pep),1,"PEP: Problem with initial vector");
    142:   PEPTOARSNorm2(lds,ctx->S,&norm);
    143:   for (j=0;j<deg;j++) {
    144:     for (i=0;i<=j;i++) ctx->S[i+j*ctx->ld] /= norm;
    145:   }
    146:   if (pep->nini<0) {
    147:     SlepcBasisDestroy_Private(&pep->nini,&pep->IS);
    148:   }
    149:   return(0);
    150: }

    154: /*
    155:  Computes GS orthogonalization   [z;x] - [Sp;Sq]*y,
    156:  where y = ([Sp;Sq]'*[z;x]).
    157:    k: Column from S to be orthogonalized against previous columns.
    158:    Sq = Sp+ld
    159:    dim(work)>=k
    160: */
    161: static PetscErrorCode PEPTOAROrth2(PEP pep,PetscScalar *S,PetscInt ld,PetscInt deg,PetscInt k,PetscScalar *y,PetscReal *norm,PetscBool *lindep,PetscScalar *work)
    162: {
    164:   PetscBLASInt   n_,lds_,k_,one=1;
    165:   PetscScalar    sonem=-1.0,sone=1.0,szero=0.0,*x0,*x,*c;
    166:   PetscInt       i,lds=deg*ld,n;
    167:   PetscReal      eta,onorm;

    170:   BVGetOrthogonalization(pep->V,NULL,NULL,&eta,NULL);
    171:   n = k+deg-1;
    172:   PetscBLASIntCast(n,&n_);
    173:   PetscBLASIntCast(deg*ld,&lds_);
    174:   PetscBLASIntCast(k,&k_); /* number of vectors to orthogonalize against them */
    175:   c = work;
    176:   x0 = S+k*lds;
    177:   PetscStackCallBLAS("BLASgemv",BLASgemv_("C",&n_,&k_,&sone,S,&lds_,x0,&one,&szero,y,&one));
    178:   for (i=1;i<deg;i++) {
    179:     x = S+i*ld+k*lds;
    180:     PetscStackCallBLAS("BLASgemv",BLASgemv_("C",&n_,&k_,&sone,S+i*ld,&lds_,x,&one,&sone,y,&one));
    181:   }
    182:   for (i=0;i<deg;i++) {
    183:     x= S+i*ld+k*lds;
    184:     PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&n_,&k_,&sonem,S+i*ld,&lds_,y,&one,&sone,x,&one));
    185:   }
    186:   PEPTOARSNorm2(lds,S+k*lds,&onorm);
    187:   /* twice */
    188:   PetscStackCallBLAS("BLASgemv",BLASgemv_("C",&n_,&k_,&sone,S,&lds_,x0,&one,&szero,c,&one));
    189:   for (i=1;i<deg;i++) {
    190:     x = S+i*ld+k*lds;
    191:     PetscStackCallBLAS("BLASgemv",BLASgemv_("C",&n_,&k_,&sone,S+i*ld,&lds_,x,&one,&sone,c,&one));
    192:   }
    193:   for (i=0;i<deg;i++) {
    194:     x= S+i*ld+k*lds;
    195:     PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&n_,&k_,&sonem,S+i*ld,&lds_,c,&one,&sone,x,&one));
    196:   }
    197:   for (i=0;i<k;i++) y[i] += c[i];
    198:   if (norm) {
    199:     PEPTOARSNorm2(lds,S+k*lds,norm);
    200:     if (lindep) *lindep = (*norm < eta * onorm)?PETSC_TRUE:PETSC_FALSE;
    201:   }
    202:   return(0);
    203: }

    207: /*
    208:   Extend the TOAR basis by applying the the matrix operator
    209:   over a vector which is decomposed in the TOAR way
    210:   Input:
    211:     - pbc: array containing the polynomial basis coefficients
    212:     - S,V: define the latest Arnoldi vector (nv vectors in V)
    213:   Output:
    214:     - t: new vector extending the TOAR basis
    215:     - r: temporary coefficients to compute the TOAR coefficients
    216:          for the new Arnoldi vector
    217:   Workspace: t_ (two vectors)
    218: */
    219: static PetscErrorCode PEPTOARExtendBasis(PEP pep,PetscBool sinvert,PetscScalar sigma,PetscScalar *S,PetscInt ls,PetscInt nv,BV V,Vec t,PetscScalar *r,PetscInt lr,Vec *t_)
    220: {
    222:   PetscInt       nmat=pep->nmat,deg=nmat-1,k,j,off=0,lss;
    223:   Vec            v=t_[0],ve=t_[1],q=t_[2];
    224:   PetscScalar    alpha=1.0,*ss,a;
    225:   PetscReal      *ca=pep->pbc,*cb=pep->pbc+nmat,*cg=pep->pbc+2*nmat;
    226:   PetscBool      flg;

    229:   BVSetActiveColumns(pep->V,0,nv);
    230:   STGetTransform(pep->st,&flg);
    231:   if (sinvert) {
    232:     for (j=0;j<nv;j++) {
    233:       if (deg>1) r[lr+j] = S[j]/ca[0];
    234:       if (deg>2) r[2*lr+j] = (S[ls+j]+(sigma-cb[1])*r[lr+j])/ca[1];
    235:     }
    236:     for (k=2;k<deg-1;k++) {
    237:       for (j=0;j<nv;j++) r[(k+1)*lr+j] = (S[k*ls+j]+(sigma-cb[k])*r[k*lr+j]-cg[k]*r[(k-1)*lr+j])/ca[k];
    238:     }
    239:     k = deg-1;
    240:     for (j=0;j<nv;j++) r[j] = (S[k*ls+j]+(sigma-cb[k])*r[k*lr+j]-cg[k]*r[(k-1)*lr+j])/ca[k];
    241:     ss = r; lss = lr; off = 1; alpha = -1.0; a = pep->sfactor;
    242:   } else {
    243:     ss = S; lss = ls; off = 0; alpha = -ca[deg-1]; a = 1.0;
    244:   }
    245:   BVMultVec(V,1.0,0.0,v,ss+off*lss);
    246:   if (pep->Dr) { /* balancing */
    247:     VecPointwiseMult(v,v,pep->Dr);
    248:   }
    249:   STMatMult(pep->st,off,v,q);
    250:   VecScale(q,a);
    251:   for (j=1+off;j<deg+off-1;j++) {
    252:     BVMultVec(V,1.0,0.0,v,ss+j*lss);
    253:     if (pep->Dr) {
    254:       VecPointwiseMult(v,v,pep->Dr);
    255:     }
    256:     STMatMult(pep->st,j,v,t);
    257:     a *= pep->sfactor;
    258:     VecAXPY(q,a,t);
    259:   }
    260:   if (sinvert) {
    261:     BVMultVec(V,1.0,0.0,v,ss);
    262:     if (pep->Dr) {
    263:       VecPointwiseMult(v,v,pep->Dr);
    264:     }
    265:     STMatMult(pep->st,deg,v,t);
    266:     a *= pep->sfactor;
    267:     VecAXPY(q,a,t);
    268:   } else {
    269:     BVMultVec(V,1.0,0.0,ve,ss+(deg-1)*lss);
    270:     if (pep->Dr) {
    271:       VecPointwiseMult(ve,ve,pep->Dr);
    272:     }
    273:     a *= pep->sfactor;
    274:     STMatMult(pep->st,deg-1,ve,t);
    275:     VecAXPY(q,a,t);
    276:     a *= pep->sfactor;
    277:   }
    278:   if (flg || !sinvert) alpha /= a;
    279:   STMatSolve(pep->st,q,t);
    280:   VecScale(t,alpha);
    281:   if (!sinvert) {
    282:     if (cg[deg-1]!=0) { VecAXPY(t,cg[deg-1],v); }
    283:     if (cb[deg-1]!=0) { VecAXPY(t,cb[deg-1],ve); }
    284:   }
    285:   if (pep->Dr) {
    286:     VecPointwiseDivide(t,t,pep->Dr);
    287:   }
    288:   return(0);
    289: }

    293: /*
    294:   Compute TOAR coefficients of the blocks of the new Arnoldi vector computed
    295: */
    296: static PetscErrorCode PEPTOARCoefficients(PEP pep,PetscBool sinvert,PetscScalar sigma,PetscInt nv,PetscScalar *S,PetscInt ls,PetscScalar *r,PetscInt lr,PetscScalar *x)
    297: {
    298:   PetscInt    k,j,nmat=pep->nmat,d=nmat-1;
    299:   PetscReal   *ca=pep->pbc,*cb=pep->pbc+nmat,*cg=pep->pbc+2*nmat;
    300:   PetscScalar t=1.0,tp=0.0,tt;

    303:   if (sinvert) {
    304:     for (k=1;k<d;k++) {
    305:       tt = t;
    306:       t = ((sigma-cb[k-1])*t-cg[k-1]*tp)/ca[k-1]; /* k-th basis polynomial */
    307:       tp = tt;
    308:       for (j=0;j<=nv;j++) r[k*lr+j] += t*x[j];
    309:     }
    310:   } else {
    311:     for (j=0;j<=nv;j++) r[j] = (cb[0]-sigma)*S[j]+ca[0]*S[ls+j];
    312:     for (k=1;k<d-1;k++) {
    313:       for (j=0;j<=nv;j++) r[k*lr+j] = (cb[k]-sigma)*S[k*ls+j]+ca[k]*S[(k+1)*ls+j]+cg[k]*S[(k-1)*ls+j];
    314:     }
    315:     if (sigma!=0.0) for (j=0;j<=nv;j++) r[(d-1)*lr+j] -= sigma*S[(d-1)*ls+j];
    316:   }
    317:   return(0);
    318: }

    322: /*
    323:   Compute a run of Arnoldi iterations dim(work)=ld
    324: */
    325: static PetscErrorCode PEPTOARrun(PEP pep,PetscScalar sigma,PetscInt *nq,PetscScalar *S,PetscInt ld,PetscScalar *H,PetscInt ldh,PetscInt k,PetscInt *M,PetscBool *breakdown,PetscScalar *work,Vec *t_)
    326: {
    328:   PetscInt       i,j,p,m=*M,nwu=0,deg=pep->nmat-1;
    329:   PetscInt       lds=ld*deg,nqt=*nq;
    330:   Vec            t;
    331:   PetscReal      norm;
    332:   PetscBool      flg,sinvert=PETSC_FALSE,lindep;
    333:   PetscScalar    *x;

    336:   STGetTransform(pep->st,&flg);
    337:   if (!flg) {
    338:     /* spectral transformation handled by the solver */
    339:     PetscObjectTypeCompareAny((PetscObject)pep->st,&flg,STSINVERT,STSHIFT,"");
    340:     if (!flg) SETERRQ(PetscObjectComm((PetscObject)pep),PETSC_ERR_SUP,"STtype not supported fr TOAR without transforming matrices");
    341:     PetscObjectTypeCompare((PetscObject)pep->st,STSINVERT,&sinvert);
    342:   }
    343:   for (j=k;j<m;j++) {
    344:     /* apply operator */
    345:     BVGetColumn(pep->V,nqt,&t);
    346:     PEPTOARExtendBasis(pep,sinvert,sigma,S+j*lds,ld,nqt,pep->V,t,S+(j+1)*lds,ld,t_);
    347:     BVRestoreColumn(pep->V,nqt,&t);

    349:     /* orthogonalize */
    350:     if (sinvert) x = S+(j+1)*lds;
    351:     else x = S+(deg-1)*ld+(j+1)*lds;
    352:     BVOrthogonalizeColumn(pep->V,nqt,x,&norm,&lindep);
    353:     if (!lindep) {
    354:       x[nqt] = norm;
    355:       BVScaleColumn(pep->V,nqt,1.0/norm);
    356:       nqt++;
    357:     }

    359:     PEPTOARCoefficients(pep,sinvert,sigma,nqt-1,S+j*lds,ld,S+(j+1)*lds,ld,x);
    360:     /* level-2 orthogonalization */
    361:     PEPTOAROrth2(pep,S,ld,deg,j+1,H+j*ldh,&norm,breakdown,work+nwu);
    362:     H[j+1+ldh*j] = norm;
    363:     *nq = nqt;
    364:     if (*breakdown) {
    365:       *M = j+1;
    366:       break;
    367:     }
    368:     for (p=0;p<deg;p++) {
    369:       for (i=0;i<=j+deg;i++) {
    370:         S[i+p*ld+(j+1)*lds] /= norm;
    371:       }
    372:     }
    373:   }
    374:   return(0);
    375: }

    379: /*
    380:   dim(rwork)=6*n; dim(work)=6*ld*lds+2*cs1
    381: */
    382: static PetscErrorCode PEPTOARTrunc(PEP pep,PetscScalar *S,PetscInt ld,PetscInt deg,PetscInt *rs1a,PetscInt cs1,PetscInt lock,PetscInt newc,PetscBool final,PetscScalar *work,PetscReal *rwork)
    383: {
    384: #if defined(PETSC_MISSING_LAPACK_GESVD) || defined(PETSC_MISSING_LAPACK_GEQRF) || defined(PETSC_MISSING_LAPACK_ORGQR)
    386:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GESVD/GEQRF/ORGQR - Lapack routine is unavailable");
    387: #else
    389:   PetscInt       nwu=0,nrwu=0,nnc,nrow,lwa;
    390:   PetscInt       j,i,k,n,lds=deg*ld,rs1=*rs1a,rk=0,offu;
    391:   PetscScalar    *M,*V,*pU,*SS,*SS2,t,sone=1.0,zero=0.0,mone=-1.0,*p,*tau;
    392:   PetscReal      *sg,tol;
    393:   PetscBLASInt   cs1_,rs1_,cs1tdeg,n_,info,lw_,newc_,newctdeg,nnc_,nrow_,nnctdeg,lds_,rk_;
    394:   Mat            U;

    397:   if (cs1==0) return(0);
    398:   lwa = 6*ld*lds+2*cs1;
    399:   n = (rs1>deg*cs1)?deg*cs1:rs1;
    400:   nnc = cs1-lock-newc;
    401:   nrow = rs1-lock;
    402:   PetscMalloc4(deg*newc*nnc,&SS,newc*nnc,&SS2,(rs1+lock+newc)*n,&pU,deg*rs1,&tau);
    403:   offu = lock*(rs1+1);
    404:   M = work+nwu;
    405:   nwu += rs1*cs1*deg;
    406:   sg = rwork+nrwu;
    407:   nrwu += n;
    408:   PetscMemzero(pU,rs1*n*sizeof(PetscScalar));
    409:   V = work+nwu;
    410:   nwu += deg*cs1*n;
    411:   PetscBLASIntCast(n,&n_);
    412:   PetscBLASIntCast(nnc,&nnc_);
    413:   PetscBLASIntCast(cs1,&cs1_);
    414:   PetscBLASIntCast(rs1,&rs1_);
    415:   PetscBLASIntCast(newc,&newc_);
    416:   PetscBLASIntCast(newc*deg,&newctdeg);
    417:   PetscBLASIntCast(nnc*deg,&nnctdeg);
    418:   PetscBLASIntCast(cs1*deg,&cs1tdeg);
    419:   PetscBLASIntCast(lwa-nwu,&lw_);
    420:   PetscBLASIntCast(nrow,&nrow_);
    421:   PetscBLASIntCast(lds,&lds_);
    422:   if (newc>0) {
    423:   /* truncate columns associated with new converged eigenpairs */
    424:     for (j=0;j<deg;j++) {
    425:       for (i=lock;i<lock+newc;i++) {
    426:         PetscMemcpy(M+(i-lock+j*newc)*nrow,S+i*lds+j*ld+lock,nrow*sizeof(PetscScalar));
    427:       }
    428:     }
    429: #if !defined (PETSC_USE_COMPLEX)
    430:     PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("S","S",&nrow_,&newctdeg,M,&nrow_,sg,pU+offu,&rs1_,V,&n_,work+nwu,&lw_,&info));
    431: #else
    432:     PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("S","S",&nrow_,&newctdeg,M,&nrow_,sg,pU+offu,&rs1_,V,&n_,work+nwu,&lw_,rwork+nrwu,&info));
    433: #endif
    434:     if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xGESVD %d",info);
    435:     /* SVD has rank min(newc,nrow) */
    436:     rk = PetscMin(newc,nrow);
    437:     for (i=0;i<rk;i++) {
    438:       t = sg[i];
    439:       PetscStackCallBLAS("BLASscal",BLASscal_(&newctdeg,&t,V+i,&n_));
    440:     }
    441:     for (i=0;i<deg;i++) {
    442:       for (j=lock;j<lock+newc;j++) {
    443:         PetscMemcpy(S+j*lds+i*ld+lock,V+(newc*i+j-lock)*n,rk*sizeof(PetscScalar));
    444:         PetscMemzero(S+j*lds+i*ld+lock+rk,(ld-lock-rk)*sizeof(PetscScalar));
    445:       }
    446:     }
    447:     /*
    448:       update columns associated with non-converged vectors, orthogonalize
    449:        against pU so that next M has rank nnc+d-1 insted of nrow+d-1
    450:     */
    451:     for (i=0;i<deg;i++) {
    452:       PetscStackCallBLAS("BLASgemm",BLASgemm_("C","N",&newc_,&nnc_,&nrow_,&sone,pU+offu,&rs1_,S+(lock+newc)*lds+i*ld+lock,&lds_,&zero,SS+i*newc*nnc,&newc_));
    453:       PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&nrow_,&nnc_,&newc_,&mone,pU+offu,&rs1_,SS+i*newc*nnc,&newc_,&sone,S+(lock+newc)*lds+i*ld+lock,&lds_));
    454:       /* repeat orthogonalization step */
    455:       PetscStackCallBLAS("BLASgemm",BLASgemm_("C","N",&newc_,&nnc_,&nrow_,&sone,pU+offu,&rs1_,S+(lock+newc)*lds+i*ld+lock,&lds_,&zero,SS2,&newc_));
    456:       PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&nrow_,&nnc_,&newc_,&mone,pU+offu,&rs1_,SS2,&newc_,&sone,S+(lock+newc)*lds+i*ld+lock,&lds_));
    457:       for (j=0;j<newc*nnc;j++) *(SS+i*newc*nnc+j) += SS2[j];
    458:     }
    459:   }
    460:   /* truncate columns associated with non-converged eigenpairs */
    461:   for (j=0;j<deg;j++) {
    462:     for (i=lock+newc;i<cs1;i++) {
    463:       PetscMemcpy(M+(i-lock-newc+j*nnc)*nrow,S+i*lds+j*ld+lock,nrow*sizeof(PetscScalar));
    464:     }
    465:   }
    466: #if !defined (PETSC_USE_COMPLEX)
    467:   PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("S","S",&nrow_,&nnctdeg,M,&nrow_,sg,pU+offu+newc*rs1,&rs1_,V,&n_,work+nwu,&lw_,&info));
    468: #else
    469:   PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("S","S",&nrow_,&nnctdeg,M,&nrow_,sg,pU+offu+newc*rs1,&rs1_,V,&n_,work+nwu,&lw_,rwork+nrwu,&info));
    470: #endif
    471:   if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xGESVD %d",info);
    472:   tol = PetscMax(rs1,deg*cs1)*PETSC_MACHINE_EPSILON*sg[0];
    473:   for (i=0;i<PetscMin(n_,nnctdeg);i++) if (sg[i]>tol) rk++;
    474:   rk = PetscMin(nnc+deg-1,rk);
    475:   /* the SVD has rank (atmost) nnc+deg-1 */
    476:   for (i=0;i<rk;i++) {
    477:     t = sg[i];
    478:     PetscStackCallBLAS("BLASscal",BLASscal_(&nnctdeg,&t,V+i,&n_));
    479:   }
    480:   /* update S */
    481:   PetscMemzero(S+cs1*lds,(ld-cs1)*lds*sizeof(PetscScalar));
    482:   k = ld-lock-newc-rk;
    483:   for (i=0;i<deg;i++) {
    484:     for (j=lock+newc;j<cs1;j++) {
    485:       PetscMemcpy(S+j*lds+i*ld+lock+newc,V+(nnc*i+j-lock-newc)*n,rk*sizeof(PetscScalar));
    486:       PetscMemzero(S+j*lds+i*ld+lock+newc+rk,k*sizeof(PetscScalar));
    487:     }
    488:   }
    489:   if (newc>0) {
    490:     for (i=0;i<deg;i++) {
    491:       p = SS+nnc*newc*i;
    492:       for (j=lock+newc;j<cs1;j++) {
    493:         for (k=0;k<newc;k++) S[j*lds+i*ld+lock+k] = *(p++);
    494:       }
    495:     }
    496:   }

    498:   /* orthogonalize pU */
    499:   rk = rk+newc;
    500:   PetscBLASIntCast(rk,&rk_);
    501:   PetscBLASIntCast(cs1-lock,&nnc_);
    502:   PetscStackCallBLAS("LAPACKgeqrf",LAPACKgeqrf_(&nrow_,&rk_,pU+offu,&rs1_,tau,work+nwu,&lw_,&info));
    503:   for (i=0;i<deg;i++) {
    504:     PetscStackCallBLAS("BLAStrmm",BLAStrmm_("L","U","N","N",&rk_,&nnc_,&sone,pU+offu,&rs1_,S+lock*lds+lock+i*ld,&lds_));
    505:   }
    506:   PetscStackCallBLAS("LAPACKungqr",LAPACKungqr_(&nrow_,&rk_,&rk_,pU+offu,&rs1_,tau,work+nwu,&lw_,&info));

    508:   /* update vectors V(:,idx) = V*Q(:,idx) */
    509:   rk = rk+lock;
    510:   for (i=0;i<lock;i++) pU[(i+1)*rs1] = 1.0;
    511:   MatCreateSeqDense(PETSC_COMM_SELF,rs1,rk,pU,&U);
    512:   BVSetActiveColumns(pep->V,lock,rs1);
    513:   BVMultInPlace(pep->V,U,lock,rk);
    514:   BVSetActiveColumns(pep->V,0,rk);
    515:   MatDestroy(&U);
    516:   *rs1a = rk;

    518:   /* free work space */
    519:   PetscFree4(SS,SS2,pU,tau);
    520:   return(0);
    521: #endif
    522: }

    526: /*
    527:   S <- S*Q
    528:   columns s-s+ncu of S
    529:   rows 0-sr of S
    530:   size(Q) qr x ncu
    531:   dim(work)=sr*ncu
    532: */
    533: static PetscErrorCode PEPTOARSupdate(PetscScalar *S,PetscInt ld,PetscInt deg,PetscInt sr,PetscInt s,PetscInt ncu,PetscInt qr,PetscScalar *Q,PetscInt ldq,PetscScalar *work)
    534: {
    536:   PetscScalar    a=1.0,b=0.0;
    537:   PetscBLASInt   sr_,ncu_,ldq_,lds_,qr_;
    538:   PetscInt       j,lds=deg*ld,i;

    541:   PetscBLASIntCast(sr,&sr_);
    542:   PetscBLASIntCast(qr,&qr_);
    543:   PetscBLASIntCast(ncu,&ncu_);
    544:   PetscBLASIntCast(lds,&lds_);
    545:   PetscBLASIntCast(ldq,&ldq_);
    546:   for (i=0;i<deg;i++) {
    547:     PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&sr_,&ncu_,&qr_,&a,S+i*ld,&lds_,Q,&ldq_,&b,work,&sr_));
    548:     for (j=0;j<ncu;j++) {
    549:       PetscMemcpy(S+lds*(s+j)+i*ld,work+j*sr,sr*sizeof(PetscScalar));
    550:     }
    551:   }
    552:   return(0);
    553: }

    557: /*
    558:   Computes T_j = phi_idx(T). In T_j and T_p are phi_{idx-1}(T)
    559:    and phi_{idx-2}(T) respectively or null if idx=0,1.
    560:    Tp and Tj are input/output arguments
    561: */
    562: static PetscErrorCode PEPEvaluateBasisM(PEP pep,PetscInt k,PetscScalar *T,PetscInt ldt,PetscInt idx,PetscScalar **Tp,PetscScalar **Tj)
    563: {
    565:   PetscInt       i;
    566:   PetscReal      *ca,*cb,*cg;
    567:   PetscScalar    *pt,g,a;
    568:   PetscBLASInt   k_,ldt_;

    571:   if (idx==0) {
    572:     PetscMemzero(*Tj,k*k*sizeof(PetscScalar));
    573:     PetscMemzero(*Tp,k*k*sizeof(PetscScalar));
    574:     for (i=0;i<k;i++) (*Tj)[i+i*k] = 1.0;
    575:   } else {
    576:     PetscBLASIntCast(ldt,&ldt_);
    577:     PetscBLASIntCast(k,&k_);
    578:     ca = pep->pbc; cb = pep->pbc+pep->nmat; cg = pep->pbc+2*pep->nmat;
    579:     for (i=0;i<k;i++) T[i*ldt+i] -= cb[idx-1];
    580:     a = 1/ca[idx-1];
    581:     g = (idx==1)?0.0:-cg[idx-1]/ca[idx-1];
    582:     PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&k_,&k_,&k_,&a,T,&ldt_,*Tj,&k_,&g,*Tp,&k_));
    583:     pt = *Tj; *Tj = *Tp; *Tp = pt;
    584:     for (i=0;i<k;i++) T[i*ldt+i] += cb[idx-1];
    585:   }
    586:   return(0);
    587: }

    591: /* dim(work)=6*sr*k;*/
    592: static PetscErrorCode PEPExtractInvariantPair(PEP pep,PetscScalar sigma,PetscInt sr,PetscInt k,PetscScalar *S,PetscInt ld,PetscInt deg,PetscScalar *H,PetscInt ldh,PetscScalar *work)
    593: {
    594: #if defined(PETSC_MISSING_LAPACK_GESV) || defined(PETSC_MISSING_LAPACK_GETRI) || defined(PETSC_MISSING_LAPACK_GETRF)
    596:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GESV/GETRI/GETRF - Lapack routine is unavailable");
    597: #else
    599:   PetscInt       nw,i,j,jj,nwu=0,lds,ldt,d=pep->nmat-1,idxcpy=0;
    600:   PetscScalar    *At,*Bt,*Hj,*Hp,*T,sone=1.0,g,a,*pM;
    601:   PetscBLASInt   k_,sr_,lds_,ldh_,info,*p,lwork,ldt_;
    602:   PetscBool      transf=PETSC_FALSE,flg;
    603:   PetscReal      nrm,norm,maxnrm,*rwork;
    604:   BV             *R,Y;
    605:   Mat            M,*A;
    606:   Vec            v;

    609:   if (k==0) return(0);
    610:   nw = 6*sr*k;
    611:   lds = deg*ld;
    612:   At = work+nwu;
    613:   nwu += sr*k;
    614:   Bt = work+nwu;
    615:   nwu += k*k;
    616:   PetscMemzero(Bt,k*k*sizeof(PetscScalar));
    617:   Hj = work+nwu;
    618:   nwu += k*k;
    619:   Hp = work+nwu;
    620:   nwu += k*k;
    621:   PetscMemzero(Hp,k*k*sizeof(PetscScalar));
    622:   PetscMalloc1(k,&p);
    623:   PetscBLASIntCast(sr,&sr_);
    624:   PetscBLASIntCast(k,&k_);
    625:   PetscBLASIntCast(lds,&lds_);
    626:   PetscBLASIntCast(ldh,&ldh_);
    627:   STGetTransform(pep->st,&flg);
    628:   if (!flg) {
    629:      PetscObjectTypeCompare((PetscObject)pep->st,STSINVERT,&flg);
    630:     if (flg || sigma!=0.0) transf=PETSC_TRUE;
    631:   }
    632:   if (transf) {
    633:     ldt = k;
    634:     T = work+nwu;
    635:     nwu += k*k;
    636:     for (i=0;i<k;i++) {
    637:       PetscMemcpy(T+k*i,H+i*ldh,k*sizeof(PetscScalar));
    638:     }
    639:     if (flg) {
    640:       PetscStackCallBLAS("LAPACKgetrf",LAPACKgetrf_(&k_,&k_,T,&k_,p,&info));
    641:       PetscBLASIntCast(nw-nwu,&lwork);
    642:       PetscStackCallBLAS("LAPACKgetri",LAPACKgetri_(&k_,T,&k_,p,work+nwu,&lwork,&info));
    643:     }
    644:     if (sigma!=0.0) for (i=0;i<k;i++) T[i+k*i] += sigma;
    645:   } else {
    646:     T = H; ldt = ldh;
    647:   }
    648:   PetscBLASIntCast(ldt,&ldt_);
    649:   switch (pep->extract) {
    650:   case PEP_EXTRACT_NONE:
    651:     break;
    652:   case PEP_EXTRACT_NORM:
    653:     if (pep->basis == PEP_BASIS_MONOMIAL) {
    654:       PetscBLASIntCast(ldt,&ldt_);
    655:       PetscMalloc1(k,&rwork);
    656:       norm = LAPACKlange_("F",&k_,&k_,T,&ldt_,rwork);
    657:       PetscFree(rwork);
    658:       if (norm>1.0) idxcpy = d-1;
    659:     } else {
    660:       PetscBLASIntCast(ldt,&ldt_);
    661:       PetscMalloc1(k,&rwork);
    662:       maxnrm = 0.0;
    663:       for (i=0;i<pep->nmat-1;i++) {
    664:         PEPEvaluateBasisM(pep,k,T,ldt,i,&Hp,&Hj);
    665:         norm = LAPACKlange_("F",&k_,&k_,Hj,&k_,rwork);
    666:         if (norm > maxnrm) {
    667:           idxcpy = i;
    668:           maxnrm = norm;
    669:         }
    670:       }
    671:       PetscFree(rwork);
    672:     }
    673:     if (idxcpy>0) {
    674:       /* copy block idxcpy of S to the first one */
    675:       for (j=0;j<k;j++) {
    676:         PetscMemcpy(S+j*lds,S+idxcpy*ld+j*lds,sr*sizeof(PetscScalar));
    677:       }
    678:     }
    679:     break;
    680:   case PEP_EXTRACT_RESIDUAL:
    681:     STGetTransform(pep->st,&flg);
    682:     if (flg) {
    683:       PetscMalloc1(pep->nmat,&A);
    684:       for (i=0;i<pep->nmat;i++) {
    685:         STGetTOperators(pep->st,i,A+i);
    686:       }
    687:     } else A = pep->A;
    688:     PetscMalloc1(pep->nmat-1,&R);
    689:     for (i=0;i<pep->nmat-1;i++) {
    690:       BVDuplicateResize(pep->V,k,R+i);
    691:     }
    692:     BVDuplicateResize(pep->V,sr,&Y);
    693:     MatCreateSeqDense(PETSC_COMM_SELF,sr,k,NULL,&M);
    694:     g = 0.0; a = 1.0;
    695:     BVSetActiveColumns(pep->V,0,sr);
    696:     for (j=0;j<pep->nmat;j++) {
    697:       BVMatMult(pep->V,A[j],Y);
    698:       PEPEvaluateBasisM(pep,k,T,ldt,i,&Hp,&Hj);
    699:       for (i=0;i<pep->nmat-1;i++) {
    700:         PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&sr_,&k_,&k_,&a,S+i*ld,&lds_,Hj,&k_,&g,At,&sr_));
    701:         MatDenseGetArray(M,&pM);
    702:         for (jj=0;jj<k;jj++) {
    703:           PetscMemcpy(pM+jj*sr,At+jj*sr,sr*sizeof(PetscScalar));
    704:         }
    705:         MatDenseRestoreArray(M,&pM);
    706:         BVMult(R[i],1.0,(i==0)?0.0:1.0,Y,M);
    707:       }
    708:     }

    710:     /* frobenius norm */
    711:     maxnrm = 0.0;
    712:     for (i=0;i<pep->nmat-1;i++) {
    713:       norm = 0.0;
    714:       for (j=0;j<k;j++) {
    715:         BVGetColumn(R[i],j,&v);
    716:         VecNorm(v,NORM_2,&nrm);
    717:         BVRestoreColumn(R[i],j,&v);
    718:         norm += nrm*nrm;
    719:       }
    720:       norm = PetscSqrtReal(norm);
    721:       if (maxnrm > norm) {
    722:         maxnrm = norm;
    723:         idxcpy = i;
    724:       }
    725:     }
    726:     if (idxcpy>0) {
    727:       /* copy block idxcpy of S to the first one */
    728:       for (j=0;j<k;j++) {
    729:         PetscMemcpy(S+j*lds,S+idxcpy*ld+j*lds,sr*sizeof(PetscScalar));
    730:       }
    731:     }
    732:     if (flg) PetscFree(A);
    733:     for (i=0;i<pep->nmat-1;i++) {
    734:       BVDestroy(&R[i]);
    735:     }
    736:     PetscFree(R);
    737:     BVDestroy(&Y);
    738:     MatDestroy(&M);
    739:     break;
    740:   case PEP_EXTRACT_STRUCTURED:
    741:     for (j=0;j<k;j++) Bt[j+j*k] = 1.0;
    742:     for (j=0;j<sr;j++) {
    743:       for (i=0;i<k;i++) At[j*k+i] = PetscConj(S[i*lds+j]);
    744:     }
    745:     PEPEvaluateBasisM(pep,k,T,ldt,0,&Hp,&Hj);
    746:     for (i=1;i<deg;i++) {
    747:       PEPEvaluateBasisM(pep,k,T,ldt,i,&Hp,&Hj);
    748:       PetscStackCallBLAS("BLASgemm",BLASgemm_("N","C",&k_,&sr_,&k_,&sone,Hj,&k_,S+i*ld,&lds_,&sone,At,&k_));
    749:       PetscStackCallBLAS("BLASgemm",BLASgemm_("N","C",&k_,&k_,&k_,&sone,Hj,&k_,Hj,&k_,&sone,Bt,&k_));
    750:     }
    751:     PetscStackCallBLAS("LAPACKgesv",LAPACKgesv_(&k_,&sr_,Bt,&k_,p,At,&k_,&info));
    752:     if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xGESV %d",info);
    753:     for (j=0;j<sr;j++) {
    754:       for (i=0;i<k;i++) S[i*lds+j] = PetscConj(At[j*k+i]);
    755:     }
    756:     break;
    757:   default:
    758:     SETERRQ(PetscObjectComm((PetscObject)pep),PETSC_ERR_SUP,"Extraction not implemented in this solver");
    759:   }
    760:   PetscFree(p);
    761:   return(0);
    762: #endif
    763: }

    767: PetscErrorCode PEPSolve_TOAR(PEP pep)
    768: {
    770:   PEP_TOAR       *ctx = (PEP_TOAR*)pep->data;
    771:   PetscInt       i,j,k,l,nv=0,ld,lds,off,ldds,newn,nq=ctx->nq,nconv=0,locked=0,newc;
    772:   PetscInt       lwa,lrwa,nwu=0,nrwu=0,nmat=pep->nmat,deg=nmat-1;
    773:   PetscScalar    *S,*Q,*work,*H,sigma;
    774:   PetscReal      beta,*rwork;
    775:   PetscBool      breakdown=PETSC_FALSE,flg,falselock=PETSC_FALSE,sinv=PETSC_FALSE;

    778:   PetscCitationsRegister(citation,&cited);
    779:   if (ctx->lock) {
    780:     PetscOptionsGetBool(NULL,NULL,"-pep_toar_falselocking",&falselock,NULL);
    781:   }
    782:   ld = ctx->ld;
    783:   S = ctx->S;
    784:   lds = deg*ld;        /* leading dimension of S */
    785:   lwa = (deg+6)*ld*lds;
    786:   lrwa = 7*lds;
    787:   PetscMalloc2(lwa,&work,lrwa,&rwork);
    788:   DSGetLeadingDimension(pep->ds,&ldds);
    789:   STGetShift(pep->st,&sigma);

    791:   /* update polynomial basis coefficients */
    792:   STGetTransform(pep->st,&flg);
    793:   if (pep->sfactor!=1.0) {
    794:     for (i=0;i<nmat;i++) {
    795:       pep->pbc[nmat+i] /= pep->sfactor;
    796:       pep->pbc[2*nmat+i] /= pep->sfactor*pep->sfactor;
    797:     }
    798:     if (!flg) {
    799:       pep->target /= pep->sfactor;
    800:       RGPushScale(pep->rg,1.0/pep->sfactor);
    801:       STScaleShift(pep->st,1.0/pep->sfactor);
    802:       sigma /= pep->sfactor;
    803:     } else {
    804:       PetscObjectTypeCompare((PetscObject)pep->st,STSINVERT,&sinv);
    805:       RGPushScale(pep->rg,sinv?pep->sfactor:1.0/pep->sfactor);
    806:       STScaleShift(pep->st,sinv?pep->sfactor:1.0/pep->sfactor);
    807:     }
    808:   }

    810:   if (flg) sigma = 0.0;

    812:   /* restart loop */
    813:   l = 0;
    814:   while (pep->reason == PEP_CONVERGED_ITERATING) {
    815:     pep->its++;

    817:     /* compute an nv-step Lanczos factorization */
    818:     nv = PetscMax(PetscMin(nconv+pep->mpd,pep->ncv),nv);
    819:     DSGetArray(pep->ds,DS_MAT_A,&H);
    820:     PEPTOARrun(pep,sigma,&nq,S,ld,H,ldds,pep->nconv+l,&nv,&breakdown,work+nwu,pep->work);
    821:     beta = PetscAbsScalar(H[(nv-1)*ldds+nv]);
    822:     DSRestoreArray(pep->ds,DS_MAT_A,&H);
    823:     DSSetDimensions(pep->ds,nv,0,pep->nconv,pep->nconv+l);
    824:     if (l==0) {
    825:       DSSetState(pep->ds,DS_STATE_INTERMEDIATE);
    826:     } else {
    827:       DSSetState(pep->ds,DS_STATE_RAW);
    828:     }

    830:     /* solve projected problem */
    831:     DSSolve(pep->ds,pep->eigr,pep->eigi);
    832:     DSSort(pep->ds,pep->eigr,pep->eigi,NULL,NULL,NULL);
    833:     DSUpdateExtraRow(pep->ds);

    835:     /* check convergence */
    836:     PEPKrylovConvergence(pep,PETSC_FALSE,pep->nconv,nv-pep->nconv,beta,&k);
    837:     (*pep->stopping)(pep,pep->its,pep->max_it,k,pep->nev,&pep->reason,pep->stoppingctx);

    839:     /* update l */
    840:     if (pep->reason != PEP_CONVERGED_ITERATING || breakdown) l = 0;
    841:     else {
    842:       l = (nv==k)?0:PetscMax(1,(PetscInt)((nv-k)*ctx->keep));
    843:       if (!breakdown) {
    844:         /* prepare the Rayleigh quotient for restart */
    845:         DSTruncate(pep->ds,k+l);
    846:         DSGetDimensions(pep->ds,&newn,NULL,NULL,NULL,NULL);
    847:         l = newn-k;
    848:       }
    849:     }
    850:     nconv = k;
    851:     if (!ctx->lock && pep->reason == PEP_CONVERGED_ITERATING && !breakdown) { l += k; k = 0; } /* non-locking variant: reset no. of converged pairs */

    853:     /* update S */
    854:     off = pep->nconv*ldds;
    855:     DSGetArray(pep->ds,DS_MAT_Q,&Q);
    856:     PEPTOARSupdate(S,ld,deg,nq,pep->nconv,k+l-pep->nconv,nv,Q+off,ldds,work+nwu);
    857:     DSRestoreArray(pep->ds,DS_MAT_Q,&Q);

    859:     /* copy last column of S */
    860:     PetscMemcpy(S+lds*(k+l),S+lds*nv,lds*sizeof(PetscScalar));

    862:     if (breakdown) {
    863:       /* stop if breakdown */
    864:       PetscInfo2(pep,"Breakdown TOAR method (it=%D norm=%g)\n",pep->its,(double)beta);
    865:       pep->reason = PEP_DIVERGED_BREAKDOWN;
    866:     }
    867:     if (pep->reason != PEP_CONVERGED_ITERATING) {l--; flg = PETSC_TRUE;}
    868:     else flg = PETSC_FALSE;
    869:     /* truncate S */
    870:     if (k+l+deg<nq) {
    871:       if (!falselock && ctx->lock) {
    872:         newc = k-pep->nconv;
    873:         PEPTOARTrunc(pep,S,ld,deg,&nq,k+l+1,locked,newc,flg,work+nwu,rwork+nrwu);
    874:         locked += newc;
    875:       } else {
    876:         PEPTOARTrunc(pep,S,ld,deg,&nq,k+l+1,0,0,flg,work+nwu,rwork+nrwu);
    877:       }
    878:     }
    879:     pep->nconv = k;
    880:     PEPMonitor(pep,pep->its,nconv,pep->eigr,pep->eigi,pep->errest,nv);
    881:   }
    882:   if (pep->nconv>0) {
    883:     /* {V*S_nconv^i}_{i=0}^{d-1} has rank nconv instead of nconv+d-1. Force zeros in each S_nconv^i block */
    884:     nq = pep->nconv;

    886:     /* perform Newton refinement if required */
    887:     if (pep->refine==PEP_REFINE_MULTIPLE && pep->rits>0) {
    888:       /* extract invariant pair */
    889:       DSGetArray(pep->ds,DS_MAT_A,&H);
    890:       PEPExtractInvariantPair(pep,sigma,nq,pep->nconv,S,ld,deg,H,ldds,work+nwu);
    891:       DSRestoreArray(pep->ds,DS_MAT_A,&H);
    892:       DSSetDimensions(pep->ds,pep->nconv,0,0,0);
    893:       DSSetState(pep->ds,DS_STATE_RAW);
    894:       PEPNewtonRefinement_TOAR(pep,sigma,&pep->rits,NULL,pep->nconv,S,lds,&nq);
    895:       DSSolve(pep->ds,pep->eigr,pep->eigi);
    896:       DSSort(pep->ds,pep->eigr,pep->eigi,NULL,NULL,NULL);
    897:       DSGetArray(pep->ds,DS_MAT_Q,&Q);
    898:       PEPTOARSupdate(S,ld,deg,nq,0,pep->nconv,pep->nconv,Q,ldds,work+nwu);
    899:       DSRestoreArray(pep->ds,DS_MAT_Q,&Q);
    900:     } else {
    901:       DSSetDimensions(pep->ds,pep->nconv,0,0,0);
    902:       DSSetState(pep->ds,DS_STATE_RAW);
    903:     }
    904:   }
    905:   if (pep->refine!=PEP_REFINE_MULTIPLE || pep->rits==0) {
    906:     STGetTransform(pep->st,&flg);
    907:     if (!flg) {
    908:       if (pep->ops->backtransform) {
    909:         (*pep->ops->backtransform)(pep);
    910:       }
    911:       /* restore original values */
    912:       pep->target *= pep->sfactor;
    913:       STScaleShift(pep->st,pep->sfactor);
    914:     } else {
    915:       STScaleShift(pep->st,sinv?1.0/pep->sfactor:pep->sfactor);
    916:     }
    917:     if (pep->sfactor!=1.0) {
    918:       for (j=0;j<pep->nconv;j++) {
    919:         pep->eigr[j] *= pep->sfactor;
    920:         pep->eigi[j] *= pep->sfactor;
    921:       }
    922:       /* restore original values */
    923:       for (i=0;i<pep->nmat;i++){
    924:         pep->pbc[pep->nmat+i] *= pep->sfactor;
    925:         pep->pbc[2*pep->nmat+i] *= pep->sfactor*pep->sfactor;
    926:       }
    927:     }
    928:   }
    929:   if (pep->sfactor!=1.0) { RGPopScale(pep->rg); }

    931:   /* change the state to raw so that DSVectors() computes eigenvectors from scratch */
    932:   DSSetDimensions(pep->ds,pep->nconv,0,0,0);
    933:   DSSetState(pep->ds,DS_STATE_RAW);

    935:   PetscFree2(work,rwork);
    936:   return(0);
    937: }

    941: static PetscErrorCode PEPTOARSetRestart_TOAR(PEP pep,PetscReal keep)
    942: {
    943:   PEP_TOAR *ctx = (PEP_TOAR*)pep->data;

    946:   if (keep==PETSC_DEFAULT) ctx->keep = 0.5;
    947:   else {
    948:     if (keep<0.1 || keep>0.9) SETERRQ(PetscObjectComm((PetscObject)pep),PETSC_ERR_ARG_OUTOFRANGE,"The keep argument must be in the range [0.1,0.9]");
    949:     ctx->keep = keep;
    950:   }
    951:   return(0);
    952: }

    956: /*@
    957:    PEPTOARSetRestart - Sets the restart parameter for the TOAR
    958:    method, in particular the proportion of basis vectors that must be kept
    959:    after restart.

    961:    Logically Collective on PEP

    963:    Input Parameters:
    964: +  pep  - the eigenproblem solver context
    965: -  keep - the number of vectors to be kept at restart

    967:    Options Database Key:
    968: .  -pep_toar_restart - Sets the restart parameter

    970:    Notes:
    971:    Allowed values are in the range [0.1,0.9]. The default is 0.5.

    973:    Level: advanced

    975: .seealso: PEPTOARGetRestart()
    976: @*/
    977: PetscErrorCode PEPTOARSetRestart(PEP pep,PetscReal keep)
    978: {

    984:   PetscTryMethod(pep,"PEPTOARSetRestart_C",(PEP,PetscReal),(pep,keep));
    985:   return(0);
    986: }

    990: static PetscErrorCode PEPTOARGetRestart_TOAR(PEP pep,PetscReal *keep)
    991: {
    992:   PEP_TOAR *ctx = (PEP_TOAR*)pep->data;

    995:   *keep = ctx->keep;
    996:   return(0);
    997: }

    1001: /*@
    1002:    PEPTOARGetRestart - Gets the restart parameter used in the TOAR method.

    1004:    Not Collective

    1006:    Input Parameter:
    1007: .  pep - the eigenproblem solver context

    1009:    Output Parameter:
    1010: .  keep - the restart parameter

    1012:    Level: advanced

    1014: .seealso: PEPTOARSetRestart()
    1015: @*/
    1016: PetscErrorCode PEPTOARGetRestart(PEP pep,PetscReal *keep)
    1017: {

    1023:   PetscUseMethod(pep,"PEPTOARGetRestart_C",(PEP,PetscReal*),(pep,keep));
    1024:   return(0);
    1025: }

    1029: static PetscErrorCode PEPTOARSetLocking_TOAR(PEP pep,PetscBool lock)
    1030: {
    1031:   PEP_TOAR *ctx = (PEP_TOAR*)pep->data;

    1034:   ctx->lock = lock;
    1035:   return(0);
    1036: }

    1040: /*@
    1041:    PEPTOARSetLocking - Choose between locking and non-locking variants of
    1042:    the TOAR method.

    1044:    Logically Collective on PEP

    1046:    Input Parameters:
    1047: +  pep  - the eigenproblem solver context
    1048: -  lock - true if the locking variant must be selected

    1050:    Options Database Key:
    1051: .  -pep_toar_locking - Sets the locking flag

    1053:    Notes:
    1054:    The default is to lock converged eigenpairs when the method restarts.
    1055:    This behaviour can be changed so that all directions are kept in the
    1056:    working subspace even if already converged to working accuracy (the
    1057:    non-locking variant).

    1059:    Level: advanced

    1061: .seealso: PEPTOARGetLocking()
    1062: @*/
    1063: PetscErrorCode PEPTOARSetLocking(PEP pep,PetscBool lock)
    1064: {

    1070:   PetscTryMethod(pep,"PEPTOARSetLocking_C",(PEP,PetscBool),(pep,lock));
    1071:   return(0);
    1072: }

    1076: static PetscErrorCode PEPTOARGetLocking_TOAR(PEP pep,PetscBool *lock)
    1077: {
    1078:   PEP_TOAR *ctx = (PEP_TOAR*)pep->data;

    1081:   *lock = ctx->lock;
    1082:   return(0);
    1083: }

    1087: /*@
    1088:    PEPTOARGetLocking - Gets the locking flag used in the TOAR method.

    1090:    Not Collective

    1092:    Input Parameter:
    1093: .  pep - the eigenproblem solver context

    1095:    Output Parameter:
    1096: .  lock - the locking flag

    1098:    Level: advanced

    1100: .seealso: PEPTOARSetLocking()
    1101: @*/
    1102: PetscErrorCode PEPTOARGetLocking(PEP pep,PetscBool *lock)
    1103: {

    1109:   PetscUseMethod(pep,"PEPTOARGetLocking_C",(PEP,PetscBool*),(pep,lock));
    1110:   return(0);
    1111: }

    1115: PetscErrorCode PEPSetFromOptions_TOAR(PetscOptionItems *PetscOptionsObject,PEP pep)
    1116: {
    1118:   PetscBool      flg,lock;
    1119:   PetscReal      keep;

    1122:   PetscOptionsHead(PetscOptionsObject,"PEP TOAR Options");
    1123:   PetscOptionsReal("-pep_toar_restart","Proportion of vectors kept after restart","PEPTOARSetRestart",0.5,&keep,&flg);
    1124:   if (flg) {
    1125:     PEPTOARSetRestart(pep,keep);
    1126:   }
    1127:   PetscOptionsBool("-pep_toar_locking","Choose between locking and non-locking variants","PEPTOARSetLocking",PETSC_FALSE,&lock,&flg);
    1128:   if (flg) {
    1129:     PEPTOARSetLocking(pep,lock);
    1130:   }
    1131:   PetscOptionsTail();
    1132:   return(0);
    1133: }

    1137: PetscErrorCode PEPView_TOAR(PEP pep,PetscViewer viewer)
    1138: {
    1140:   PEP_TOAR       *ctx = (PEP_TOAR*)pep->data;
    1141:   PetscBool      isascii;

    1144:   PetscObjectTypeCompare((PetscObject)viewer,PETSCVIEWERASCII,&isascii);
    1145:   if (isascii) {
    1146:     PetscViewerASCIIPrintf(viewer,"  TOAR: %d%% of basis vectors kept after restart\n",(int)(100*ctx->keep));
    1147:     PetscViewerASCIIPrintf(viewer,"  TOAR: using the %slocking variant\n",ctx->lock?"":"non-");
    1148:   }
    1149:   return(0);
    1150: }

    1154: PetscErrorCode PEPDestroy_TOAR(PEP pep)
    1155: {

    1159:   PetscFree(pep->data);
    1160:   PetscObjectComposeFunction((PetscObject)pep,"PEPTOARSetRestart_C",NULL);
    1161:   PetscObjectComposeFunction((PetscObject)pep,"PEPTOARGetRestart_C",NULL);
    1162:   PetscObjectComposeFunction((PetscObject)pep,"PEPTOARSetLocking_C",NULL);
    1163:   PetscObjectComposeFunction((PetscObject)pep,"PEPTOARGetLocking_C",NULL);
    1164:   return(0);
    1165: }

    1169: PETSC_EXTERN PetscErrorCode PEPCreate_TOAR(PEP pep)
    1170: {
    1171:   PEP_TOAR       *ctx;

    1175:   PetscNewLog(pep,&ctx);
    1176:   pep->data = (void*)ctx;
    1177:   ctx->lock = PETSC_TRUE;

    1179:   pep->ops->solve          = PEPSolve_TOAR;
    1180:   pep->ops->setup          = PEPSetUp_TOAR;
    1181:   pep->ops->setfromoptions = PEPSetFromOptions_TOAR;
    1182:   pep->ops->destroy        = PEPDestroy_TOAR;
    1183:   pep->ops->view           = PEPView_TOAR;
    1184:   pep->ops->backtransform  = PEPBackTransform_Default;
    1185:   pep->ops->computevectors = PEPComputeVectors_Default;
    1186:   pep->ops->extractvectors = PEPExtractVectors_TOAR;
    1187:   pep->ops->reset          = PEPReset_TOAR;
    1188:   PetscObjectComposeFunction((PetscObject)pep,"PEPTOARSetRestart_C",PEPTOARSetRestart_TOAR);
    1189:   PetscObjectComposeFunction((PetscObject)pep,"PEPTOARGetRestart_C",PEPTOARGetRestart_TOAR);
    1190:   PetscObjectComposeFunction((PetscObject)pep,"PEPTOARSetLocking_C",PEPTOARSetLocking_TOAR);
    1191:   PetscObjectComposeFunction((PetscObject)pep,"PEPTOARGetLocking_C",PEPTOARGetLocking_TOAR);
    1192:   return(0);
    1193: }