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

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

      1: /*

      3:    SLEPc eigensolver: "ciss"

      5:    Method: Contour Integral Spectral Slicing

      7:    Algorithm:

      9:        Contour integral based on Sakurai-Sugiura method to construct a
     10:        subspace, with various eigenpair extractions (Rayleigh-Ritz,
     11:        explicit moment).

     13:    Based on code contributed by Y. Maeda, T. Sakurai.

     15:    References:

     17:        [1] T. Sakurai and H. Sugiura, "A projection method for generalized
     18:            eigenvalue problems", J. Comput. Appl. Math. 159:119-128, 2003.

     20:        [2] T. Sakurai and H. Tadano, "CIRR: a Rayleigh-Ritz type method with
     21:            contour integral for generalized eigenvalue problems", Hokkaido
     22:            Math. J. 36:745-757, 2007.

     24:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
     25:    SLEPc - Scalable Library for Eigenvalue Problem Computations
     26:    Copyright (c) 2002-2016, Universitat Politecnica de Valencia, Spain

     28:    This file is part of SLEPc.

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

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

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

     44: #include <slepc/private/epsimpl.h>                /*I "slepceps.h" I*/
     45: #include <slepcblaslapack.h>

     47: typedef struct {
     48:   /* parameters */
     49:   PetscInt          N;          /* number of integration points (32) */
     50:   PetscInt          L;          /* block size (16) */
     51:   PetscInt          M;          /* moment degree (N/4 = 4) */
     52:   PetscReal         delta;      /* threshold of singular value (1e-12) */
     53:   PetscInt          L_max;      /* maximum number of columns of the source matrix V */
     54:   PetscReal         spurious_threshold; /* discard spurious eigenpairs */
     55:   PetscBool         isreal;     /* A and B are real */
     56:   PetscInt          refine_inner;
     57:   PetscInt          refine_blocksize;
     58:   /* private data */
     59:   PetscReal         *sigma;     /* threshold for numerical rank */
     60:   PetscInt          num_subcomm;
     61:   PetscInt          subcomm_id;
     62:   PetscInt          num_solve_point;
     63:   PetscScalar       *weight;
     64:   PetscScalar       *omega;
     65:   PetscScalar       *pp;
     66:   BV                V;
     67:   BV                S;
     68:   BV                pV;
     69:   BV                Y;
     70:   Vec               xsub;
     71:   Vec               xdup;
     72:   KSP               *ksp;
     73:   Mat               *kspMat;
     74:   PetscBool         useconj;
     75:   PetscReal         est_eig;
     76:   VecScatter        scatterin;
     77:   Mat               pA,pB;
     78:   PetscSubcomm      subcomm;
     79:   PetscBool         usest;
     80:   PetscBool         usest_set;  /* whether the user set the usest flag or not */
     81:   EPSCISSQuadRule   quad;
     82:   EPSCISSExtraction extraction;
     83: } EPS_CISS;

     87: static PetscErrorCode SetSolverComm(EPS eps)
     88: {
     90:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
     91:   PetscInt       N = ctx->N;

     94:   if (ctx->useconj) N = N/2;
     95:   if (!ctx->subcomm) {
     96:     PetscSubcommCreate(PetscObjectComm((PetscObject)eps),&ctx->subcomm);
     97:     PetscSubcommSetNumber(ctx->subcomm,ctx->num_subcomm);
     98:     PetscSubcommSetType(ctx->subcomm,PETSC_SUBCOMM_INTERLACED);
     99:     PetscLogObjectMemory((PetscObject)eps,sizeof(PetscSubcomm));
    100:     PetscSubcommSetFromOptions(ctx->subcomm);
    101:   }
    102:   ctx->subcomm_id = ctx->subcomm->color;
    103:   ctx->num_solve_point = N / ctx->num_subcomm;
    104:   if ((N%ctx->num_subcomm) > ctx->subcomm_id) ctx->num_solve_point+=1;
    105:   return(0);
    106: }

    110: static PetscErrorCode CISSRedundantMat(EPS eps)
    111: {
    113:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    114:   Mat            A,B;
    115:   PetscInt       nmat;

    118:   STGetNumMatrices(eps->st,&nmat);
    119:   if (ctx->subcomm->n != 1) {
    120:     STGetOperators(eps->st,0,&A);
    121:     MatCreateRedundantMatrix(A,ctx->subcomm->n,PetscSubcommChild(ctx->subcomm),MAT_INITIAL_MATRIX,&ctx->pA);
    122:     if (nmat>1) {
    123:       STGetOperators(eps->st,1,&B);
    124:       MatCreateRedundantMatrix(B,ctx->subcomm->n,PetscSubcommChild(ctx->subcomm),MAT_INITIAL_MATRIX,&ctx->pB);
    125:     } else ctx->pB = NULL;
    126:   } else {
    127:     ctx->pA = NULL;
    128:     ctx->pB = NULL;
    129:   }
    130:   return(0);
    131: }

    135: static PetscErrorCode CISSScatterVec(EPS eps)
    136: {
    138:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    139:   IS             is1,is2;
    140:   Vec            v0;
    141:   PetscInt       i,j,k,mstart,mend,mlocal;
    142:   PetscInt       *idx1,*idx2,mloc_sub;

    145:   MatCreateVecs(ctx->pA,&ctx->xsub,NULL);
    146:   MatGetLocalSize(ctx->pA,&mloc_sub,NULL);
    147:   VecCreateMPI(PetscSubcommContiguousParent(ctx->subcomm),mloc_sub,PETSC_DECIDE,&ctx->xdup);
    148:   if (!ctx->scatterin) {
    149:     BVGetColumn(ctx->V,0,&v0);
    150:     VecGetOwnershipRange(v0,&mstart,&mend);
    151:     mlocal = mend - mstart;
    152:     PetscMalloc2(ctx->subcomm->n*mlocal,&idx1,ctx->subcomm->n*mlocal,&idx2);
    153:     j = 0;
    154:     for (k=0;k<ctx->subcomm->n;k++) {
    155:       for (i=mstart;i<mend;i++) {
    156:         idx1[j]   = i;
    157:         idx2[j++] = i + eps->n*k;
    158:       }
    159:     }
    160:     ISCreateGeneral(PetscObjectComm((PetscObject)eps),ctx->subcomm->n*mlocal,idx1,PETSC_COPY_VALUES,&is1);
    161:     ISCreateGeneral(PetscObjectComm((PetscObject)eps),ctx->subcomm->n*mlocal,idx2,PETSC_COPY_VALUES,&is2);
    162:     VecScatterCreate(v0,is1,ctx->xdup,is2,&ctx->scatterin);
    163:     ISDestroy(&is1);
    164:     ISDestroy(&is2);
    165:     PetscFree2(idx1,idx2);
    166:     BVRestoreColumn(ctx->V,0,&v0);
    167:   }
    168:   return(0);
    169: }

    173: static PetscErrorCode SetPathParameter(EPS eps)
    174: {
    176:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    177:   PetscInt       i,j;
    178:   PetscScalar    center=0.0,tmp,tmp2,*omegai;
    179:   PetscReal      theta,radius=1.0,vscale,a,b,c,d,max_w=0.0,rgscale;
    180: #if defined(PETSC_USE_COMPLEX)
    181:   PetscReal      start_ang,end_ang;
    182: #endif
    183:   PetscBool      isring=PETSC_FALSE,isellipse=PETSC_FALSE,isinterval=PETSC_FALSE;

    186:   PetscObjectTypeCompare((PetscObject)eps->rg,RGELLIPSE,&isellipse);
    187:   PetscObjectTypeCompare((PetscObject)eps->rg,RGRING,&isring);
    188:   PetscObjectTypeCompare((PetscObject)eps->rg,RGINTERVAL,&isinterval);
    189:   RGGetScale(eps->rg,&rgscale);
    190:   PetscMalloc1(ctx->N+1l,&omegai);
    191:   RGComputeContour(eps->rg,ctx->N,ctx->omega,omegai);
    192:   if (isellipse) {
    193:     RGEllipseGetParameters(eps->rg,&center,&radius,&vscale);
    194:     for (i=0;i<ctx->N;i++) {
    195: #if defined(PETSC_USE_COMPLEX)
    196:       theta = 2.0*PETSC_PI*(i+0.5)/ctx->N;
    197:       ctx->pp[i] = PetscCosReal(theta)+vscale*PetscSinReal(theta)*PETSC_i;
    198:       ctx->weight[i] = rgscale*radius*(vscale*PetscCosReal(theta)+PetscSinReal(theta)*PETSC_i)/(PetscReal)ctx->N;
    199: #else
    200:       theta = (PETSC_PI/ctx->N)*(i+0.5);
    201:       ctx->pp[i] = PetscCosReal(theta);
    202:       ctx->weight[i] = PetscCosReal((ctx->N-1)*theta)/ctx->N;
    203:       ctx->omega[i] = rgscale*(center + radius*ctx->pp[i]);
    204: #endif
    205:     }
    206:   } else if (ctx->quad == EPS_CISS_QUADRULE_CHEBYSHEV) {
    207:     for (i=0;i<ctx->N;i++) {
    208:       theta = (PETSC_PI/ctx->N)*(i+0.5);
    209:       ctx->pp[i] = PetscCosReal(theta);
    210:       ctx->weight[i] = PetscCosReal((ctx->N-1)*theta)/ctx->N;
    211:     }
    212:     if (isinterval) {
    213:       RGIntervalGetEndpoints(eps->rg,&a,&b,&c,&d);
    214:       if ((c!=d || c!=0.0) && (a!=b || a!=0.0)) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_SUP,"Endpoints of the imaginary axis or the real axis must be both zero");
    215:       for (i=0;i<ctx->N;i++) {
    216:         if (c==d) ctx->omega[i] = ((b-a)*(ctx->pp[i]+1.0)/2.0+a)*rgscale;
    217:         if (a==b) {
    218: #if defined(PETSC_USE_COMPLEX)
    219:           ctx->omega[i] = ((d-c)*(ctx->pp[i]+1.0)/2.0+c)*rgscale*PETSC_i;
    220: #else
    221:           SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Integration points on a vertical line require complex arithmetic");
    222: #endif
    223:         }
    224:       }
    225:     }
    226:     if (isring) {  /* only supported in complex scalars */
    227: #if defined(PETSC_USE_COMPLEX)
    228:       RGRingGetParameters(eps->rg,&center,&radius,&vscale,&start_ang,&end_ang,NULL);
    229:       for (i=0;i<ctx->N;i++) {
    230:         theta = (start_ang*2.0+(end_ang-start_ang)*(PetscRealPart(ctx->pp[i])+1.0))*PETSC_PI;
    231:         ctx->omega[i] = rgscale*(center + radius*(PetscCosReal(theta)+PETSC_i*vscale*PetscSinReal(theta)));
    232:       }
    233: #endif
    234:     }
    235:   } else {
    236:     if (isinterval) {
    237:       RGIntervalGetEndpoints(eps->rg,&a,&b,&c,&d);
    238:       center = rgscale*((b+a)/2.0+(d+c)/2.0*PETSC_PI);
    239:       radius = PetscSqrtReal(PetscPowRealInt(rgscale*(b-a)/2.0,2)+PetscPowRealInt(rgscale*(d-c)/2.0,2));
    240:     } else if (isring) {
    241:       RGRingGetParameters(eps->rg,&center,&radius,NULL,NULL,NULL,NULL);
    242:       center *= rgscale;
    243:       radius *= rgscale;
    244:     }
    245:     for (i=0;i<ctx->N;i++) {
    246:       ctx->pp[i] = (ctx->omega[i]-center)/radius;
    247:       tmp = 1; tmp2 = 1;
    248:       for (j=0;j<ctx->N;j++) {
    249:         tmp *= ctx->omega[j];
    250:         if (i != j) tmp2 *= ctx->omega[j]-ctx->omega[i];
    251:       }
    252:       ctx->weight[i] = tmp/tmp2;
    253:       max_w = PetscMax(PetscAbsScalar(ctx->weight[i]),max_w);
    254:     }
    255:     for (i=0;i<ctx->N;i++) ctx->weight[i] /= (PetscScalar)max_w;
    256:   }
    257:   PetscFree(omegai);
    258:   return(0);
    259: }

    263: static PetscErrorCode CISSVecSetRandom(BV V,PetscInt i0,PetscInt i1)
    264: {
    266:   PetscInt       i,j,nlocal;
    267:   PetscScalar    *vdata;
    268:   Vec            x;

    271:   BVGetSizes(V,&nlocal,NULL,NULL);
    272:   for (i=i0;i<i1;i++) {
    273:     BVSetRandomColumn(V,i);
    274:     BVGetColumn(V,i,&x);
    275:     VecGetArray(x,&vdata);
    276:     for (j=0;j<nlocal;j++) {
    277:       vdata[j] = PetscRealPart(vdata[j]);
    278:       if (PetscRealPart(vdata[j]) < 0.5) vdata[j] = -1.0;
    279:       else vdata[j] = 1.0;
    280:     }
    281:     VecRestoreArray(x,&vdata);
    282:     BVRestoreColumn(V,i,&x);
    283:   }
    284:   return(0);
    285: }

    289: static PetscErrorCode VecScatterVecs(EPS eps,BV Vin,PetscInt n)
    290: {
    291:   PetscErrorCode    ierr;
    292:   EPS_CISS          *ctx = (EPS_CISS*)eps->data;
    293:   PetscInt          i;
    294:   Vec               vi,pvi;
    295:   const PetscScalar *array;

    298:   for (i=0;i<n;i++) {
    299:     BVGetColumn(Vin,i,&vi);
    300:     VecScatterBegin(ctx->scatterin,vi,ctx->xdup,INSERT_VALUES,SCATTER_FORWARD);
    301:     VecScatterEnd(ctx->scatterin,vi,ctx->xdup,INSERT_VALUES,SCATTER_FORWARD);
    302:     BVRestoreColumn(Vin,i,&vi);
    303:     VecGetArrayRead(ctx->xdup,&array);
    304:     VecPlaceArray(ctx->xsub,array);
    305:     BVGetColumn(ctx->pV,i,&pvi);
    306:     VecCopy(ctx->xsub,pvi);
    307:     BVRestoreColumn(ctx->pV,i,&pvi);
    308:     VecResetArray(ctx->xsub);
    309:     VecRestoreArrayRead(ctx->xdup,&array);
    310:   }
    311:   return(0);
    312: }

    316: static PetscErrorCode SolveLinearSystem(EPS eps,Mat A,Mat B,BV V,PetscInt L_start,PetscInt L_end,PetscBool initksp)
    317: {
    319:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    320:   PetscInt       i,j,p_id;
    321:   Mat            Fz;
    322:   PC             pc;
    323:   Vec            Bvj,vj,yj;
    324:   KSP            ksp;

    327:   BVCreateVec(V,&Bvj);
    328:   if (ctx->usest) {
    329:     MatDuplicate(A,MAT_DO_NOT_COPY_VALUES,&Fz);
    330:   }
    331:   for (i=0;i<ctx->num_solve_point;i++) {
    332:     p_id = i*ctx->subcomm->n + ctx->subcomm_id;
    333:     if (!ctx->usest && initksp == PETSC_TRUE) {
    334:       MatDuplicate(A,MAT_DO_NOT_COPY_VALUES,&ctx->kspMat[i]);
    335:       MatCopy(A,ctx->kspMat[i],DIFFERENT_NONZERO_PATTERN);
    336:       if (B) {
    337:         MatAXPY(ctx->kspMat[i],-ctx->omega[p_id],B,DIFFERENT_NONZERO_PATTERN);
    338:       } else {
    339:         MatShift(ctx->kspMat[i],-ctx->omega[p_id]);
    340:       }
    341:       KSPSetOperators(ctx->ksp[i],ctx->kspMat[i],ctx->kspMat[i]);
    342:       KSPSetType(ctx->ksp[i],KSPPREONLY);
    343:       KSPGetPC(ctx->ksp[i],&pc);
    344:       PCSetType(pc,PCLU);
    345:       KSPSetFromOptions(ctx->ksp[i]);
    346:     } else if (ctx->usest) {
    347:       STSetShift(eps->st,ctx->omega[p_id]);
    348:       STGetKSP(eps->st,&ksp);
    349:     }
    350:     for (j=L_start;j<L_end;j++) {
    351:       BVGetColumn(V,j,&vj);
    352:       BVGetColumn(ctx->Y,i*ctx->L_max+j,&yj);
    353:       if (B) {
    354:         MatMult(B,vj,Bvj);
    355:         if (ctx->usest) {
    356:           KSPSolve(ksp,Bvj,yj);
    357:         } else {
    358:           KSPSolve(ctx->ksp[i],Bvj,yj);
    359:         }
    360:       } else {
    361:         if (ctx->usest) {
    362:           KSPSolve(ksp,vj,yj);
    363:         } else {
    364:           KSPSolve(ctx->ksp[i],vj,yj);
    365:         }
    366:       }
    367:       BVRestoreColumn(V,j,&vj);
    368:       BVRestoreColumn(ctx->Y,i*ctx->L_max+j,&yj);
    369:     }
    370:     if (ctx->usest && i<ctx->num_solve_point-1) {  KSPReset(ksp); }
    371:   }
    372:   if (ctx->usest) { MatDestroy(&Fz); }
    373:   VecDestroy(&Bvj);
    374:   return(0);
    375: }

    377: #if defined(PETSC_USE_COMPLEX)
    380: static PetscErrorCode EstimateNumberEigs(EPS eps,PetscInt *L_add)
    381: {
    383:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    384:   PetscInt       i,j,p_id;
    385:   PetscScalar    tmp,m = 1,sum = 0.0;
    386:   PetscReal      eta;
    387:   Vec            v,vtemp,vj,yj;

    390:   BVGetColumn(ctx->Y,0,&yj);
    391:   VecDuplicate(yj,&v);
    392:   BVRestoreColumn(ctx->Y,0,&yj);
    393:   BVCreateVec(ctx->V,&vtemp);
    394:   for (j=0;j<ctx->L;j++) {
    395:     VecSet(v,0);
    396:     for (i=0;i<ctx->num_solve_point; i++) {
    397:       p_id = i*ctx->subcomm->n + ctx->subcomm_id;
    398:       BVSetActiveColumns(ctx->Y,i*ctx->L_max+j,i*ctx->L_max+j+1);
    399:       BVMultVec(ctx->Y,ctx->weight[p_id],1,v,&m);
    400:     }
    401:     BVGetColumn(ctx->V,j,&vj);
    402:     if (ctx->pA) {
    403:       VecSet(vtemp,0);
    404:       VecScatterBegin(ctx->scatterin,v,vtemp,ADD_VALUES,SCATTER_REVERSE);
    405:       VecScatterEnd(ctx->scatterin,v,vtemp,ADD_VALUES,SCATTER_REVERSE);
    406:       VecDot(vj,vtemp,&tmp);
    407:     } else {
    408:       VecDot(vj,v,&tmp);
    409:     }
    410:     BVRestoreColumn(ctx->V,j,&vj);
    411:     if (ctx->useconj) sum += PetscRealPart(tmp)*2;
    412:     else sum += tmp;
    413:   }
    414:   ctx->est_eig = PetscAbsScalar(sum/(PetscReal)ctx->L);
    415:   eta = PetscPowReal(10.0,-PetscLog10Real(eps->tol)/ctx->N);
    416:   PetscInfo1(eps,"Estimation_#Eig %f\n",(double)ctx->est_eig);
    417:   *L_add = (PetscInt)PetscCeilReal((ctx->est_eig*eta)/ctx->M) - ctx->L;
    418:   if (*L_add < 0) *L_add = 0;
    419:   if (*L_add>ctx->L_max-ctx->L) {
    420:     PetscInfo(eps,"Number of eigenvalues around the contour path may be too large\n");
    421:     *L_add = ctx->L_max-ctx->L;
    422:   }
    423:   VecDestroy(&v);
    424:   VecDestroy(&vtemp);
    425:   return(0);
    426: }
    427: #endif

    431: static PetscErrorCode CalcMu(EPS eps,PetscScalar *Mu)
    432: {
    434:   PetscMPIInt    sub_size,len;
    435:   PetscInt       i,j,k,s;
    436:   PetscScalar    *m,*temp,*temp2,*ppk,alp;
    437:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    438:   Mat            M;

    441:   MPI_Comm_size(PetscSubcommChild(ctx->subcomm),&sub_size);
    442:   PetscMalloc3(ctx->num_solve_point*ctx->L*(ctx->L+1),&temp,2*ctx->M*ctx->L*ctx->L,&temp2,ctx->num_solve_point,&ppk);
    443:   MatCreateSeqDense(PETSC_COMM_SELF,ctx->L,ctx->L_max*ctx->num_solve_point,NULL,&M);
    444:   for (i=0;i<2*ctx->M*ctx->L*ctx->L;i++) temp2[i] = 0;
    445:   BVSetActiveColumns(ctx->Y,0,ctx->L_max*ctx->num_solve_point);
    446:   if (ctx->pA) {
    447:     BVSetActiveColumns(ctx->pV,0,ctx->L);
    448:     BVDot(ctx->Y,ctx->pV,M);
    449:   } else {
    450:     BVSetActiveColumns(ctx->V,0,ctx->L);
    451:     BVDot(ctx->Y,ctx->V,M);
    452:   }
    453:   MatDenseGetArray(M,&m);
    454:   for (i=0;i<ctx->num_solve_point;i++) {
    455:     for (j=0;j<ctx->L;j++) {
    456:       for (k=0;k<ctx->L;k++) {
    457:         temp[k+j*ctx->L+i*ctx->L*ctx->L]=m[k+j*ctx->L+i*ctx->L*ctx->L_max];
    458:       }
    459:     }
    460:   }
    461:   MatDenseRestoreArray(M,&m);
    462:   for (i=0;i<ctx->num_solve_point;i++) ppk[i] = 1;
    463:   for (k=0;k<2*ctx->M;k++) {
    464:     for (j=0;j<ctx->L;j++) {
    465:       for (i=0;i<ctx->num_solve_point;i++) {
    466:         alp = ppk[i]*ctx->weight[i*ctx->subcomm->n + ctx->subcomm_id];
    467:         for (s=0;s<ctx->L;s++) {
    468:           if (ctx->useconj) temp2[s+(j+k*ctx->L)*ctx->L] += PetscRealPart(alp*temp[s+(j+i*ctx->L)*ctx->L])*2;
    469:           else temp2[s+(j+k*ctx->L)*ctx->L] += alp*temp[s+(j+i*ctx->L)*ctx->L];
    470:         }
    471:       }
    472:     }
    473:     for (i=0;i<ctx->num_solve_point;i++)
    474:       ppk[i] *= ctx->pp[i*ctx->subcomm->n + ctx->subcomm_id];
    475:   }
    476:   for (i=0;i<2*ctx->M*ctx->L*ctx->L;i++) temp2[i] /= sub_size;
    477:   PetscMPIIntCast(2*ctx->M*ctx->L*ctx->L,&len);
    478:   MPI_Allreduce(temp2,Mu,len,MPIU_SCALAR,MPIU_SUM,PetscObjectComm((PetscObject)eps));
    479:   PetscFree3(temp,temp2,ppk);
    480:   MatDestroy(&M);
    481:   return(0);
    482: }

    486: static PetscErrorCode BlockHankel(EPS eps,PetscScalar *Mu,PetscInt s,PetscScalar *H)
    487: {
    488:   EPS_CISS *ctx = (EPS_CISS*)eps->data;
    489:   PetscInt i,j,k,L=ctx->L,M=ctx->M;

    492:   for (k=0;k<L*M;k++)
    493:     for (j=0;j<M;j++)
    494:       for (i=0;i<L;i++)
    495:         H[j*L+i+k*L*M] = Mu[i+k*L+(j+s)*L*L];
    496:   return(0);
    497: }

    501: static PetscErrorCode SVD_H0(EPS eps,PetscScalar *S,PetscInt *K)
    502: {
    503: #if defined(PETSC_MISSING_LAPACK_GESVD)
    505:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GESVD - Lapack routine is unavailable");
    506: #else
    508:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    509:   PetscInt       i,ml=ctx->L*ctx->M;
    510:   PetscBLASInt   m,n,lda,ldu,ldvt,lwork,info;
    511:   PetscScalar    *work;
    512: #if defined(PETSC_USE_COMPLEX)
    513:   PetscReal      *rwork;
    514: #endif

    517:   PetscMalloc1(5*ml,&work);
    518: #if defined(PETSC_USE_COMPLEX)
    519:   PetscMalloc1(5*ml,&rwork);
    520: #endif
    521:   PetscBLASIntCast(ml,&m);
    522:   n = m; lda = m; ldu = m; ldvt = m; lwork = 5*m;
    523:   PetscFPTrapPush(PETSC_FP_TRAP_OFF);
    524: #if defined(PETSC_USE_COMPLEX)
    525:   PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("N","N",&m,&n,S,&lda,ctx->sigma,NULL,&ldu,NULL,&ldvt,work,&lwork,rwork,&info));
    526: #else
    527:   PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("N","N",&m,&n,S,&lda,ctx->sigma,NULL,&ldu,NULL,&ldvt,work,&lwork,&info));
    528: #endif
    529:   if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xGESVD %d",info);
    530:   PetscFPTrapPop();
    531:   (*K) = 0;
    532:   for (i=0;i<ml;i++) {
    533:     if (ctx->sigma[i]/PetscMax(ctx->sigma[0],1)>ctx->delta) (*K)++;
    534:   }
    535:   PetscFree(work);
    536: #if defined(PETSC_USE_COMPLEX)
    537:   PetscFree(rwork);
    538: #endif
    539:   return(0);
    540: #endif
    541: }

    545: static PetscErrorCode ConstructS(EPS eps)
    546: {
    548:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    549:   PetscInt       i,j,k,vec_local_size,p_id;
    550:   Vec            v,sj,yj;
    551:   PetscScalar    *ppk, *v_data, m = 1;

    554:   BVGetSizes(ctx->Y,&vec_local_size,NULL,NULL);
    555:   PetscMalloc1(ctx->num_solve_point,&ppk);
    556:   for (i=0;i<ctx->num_solve_point;i++) ppk[i] = 1;
    557:   BVGetColumn(ctx->Y,0,&yj);
    558:   VecDuplicate(yj,&v);
    559:   BVRestoreColumn(ctx->Y,0,&yj);
    560:   for (k=0;k<ctx->M;k++) {
    561:     for (j=0;j<ctx->L;j++) {
    562:       VecSet(v,0);
    563:       for (i=0;i<ctx->num_solve_point;i++) {
    564:         p_id = i*ctx->subcomm->n + ctx->subcomm_id;
    565:         BVSetActiveColumns(ctx->Y,i*ctx->L_max+j,i*ctx->L_max+j+1);
    566:         BVMultVec(ctx->Y,ppk[i]*ctx->weight[p_id],1.0,v,&m);
    567:       }
    568:       if (ctx->useconj) {
    569:         VecGetArray(v,&v_data);
    570:         for (i=0;i<vec_local_size;i++) v_data[i] = PetscRealPart(v_data[i])*2;
    571:         VecRestoreArray(v,&v_data);
    572:       }
    573:       BVGetColumn(ctx->S,k*ctx->L+j,&sj);
    574:       if (ctx->pA) {
    575:         VecSet(sj,0);
    576:         VecScatterBegin(ctx->scatterin,v,sj,ADD_VALUES,SCATTER_REVERSE);
    577:         VecScatterEnd(ctx->scatterin,v,sj,ADD_VALUES,SCATTER_REVERSE);
    578:       } else {
    579:         VecCopy(v,sj);
    580:       }
    581:       BVRestoreColumn(ctx->S,k*ctx->L+j,&sj);
    582:     }
    583:     for (i=0;i<ctx->num_solve_point;i++) {
    584:       p_id = i*ctx->subcomm->n + ctx->subcomm_id;
    585:       ppk[i] *= ctx->pp[p_id];
    586:     }
    587:   }
    588:   PetscFree(ppk);
    589:   VecDestroy(&v);
    590:   return(0);
    591: }

    595: static PetscErrorCode SVD_S(BV S,PetscInt ml,PetscReal delta,PetscReal *sigma,PetscInt *K)
    596: {
    597: #if defined(PETSC_MISSING_LAPACK_GESVD)
    599:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GESVD - Lapack routine is unavailable");
    600: #else
    602:   PetscInt       i,j,k,local_size;
    603:   PetscMPIInt    len;
    604:   PetscScalar    *work,*temp,*B,*tempB,*s_data,*Q1,*Q2,*temp2,alpha=1,beta=0;
    605:   PetscBLASInt   l,m,n,lda,ldu,ldvt,lwork,info,ldb,ldc;
    606: #if defined(PETSC_USE_COMPLEX)
    607:   PetscReal      *rwork;
    608: #endif

    611:   BVGetSizes(S,&local_size,NULL,NULL);
    612:   BVGetArray(S,&s_data);
    613:   PetscMalloc7(ml*ml,&temp,ml*ml,&temp2,local_size*ml,&Q1,local_size*ml,&Q2,ml*ml,&B,ml*ml,&tempB,5*ml,&work);
    614:   PetscMemzero(B,ml*ml*sizeof(PetscScalar));
    615: #if defined(PETSC_USE_COMPLEX)
    616:   PetscMalloc1(5*ml,&rwork);
    617: #endif
    618:   PetscFPTrapPush(PETSC_FP_TRAP_OFF);

    620:   for (i=0;i<ml;i++) B[i*ml+i]=1;

    622:   for (k=0;k<2;k++) {
    623:     PetscBLASIntCast(local_size,&m);
    624:     PetscBLASIntCast(ml,&l);
    625:     n = l; lda = m; ldb = m; ldc = l;
    626:     if (k == 0) {
    627:       PetscStackCallBLAS("BLASgemm",BLASgemm_("C","N",&l,&n,&m,&alpha,s_data,&lda,s_data,&ldb,&beta,temp,&ldc));
    628:     } else if ((k%2)==1) {
    629:       PetscStackCallBLAS("BLASgemm",BLASgemm_("C","N",&l,&n,&m,&alpha,Q1,&lda,Q1,&ldb,&beta,temp,&ldc));
    630:     } else {
    631:       PetscStackCallBLAS("BLASgemm",BLASgemm_("C","N",&l,&n,&m,&alpha,Q2,&lda,Q2,&ldb,&beta,temp,&ldc));
    632:     }
    633:     PetscMemzero(temp2,ml*ml*sizeof(PetscScalar));
    634:     PetscMPIIntCast(ml*ml,&len);
    635:     MPI_Allreduce(temp,temp2,len,MPIU_SCALAR,MPIU_SUM,PetscObjectComm((PetscObject)S));

    637:     PetscBLASIntCast(ml,&m);
    638:     n = m; lda = m; lwork = 5*m, ldu = 1; ldvt = 1;
    639: #if defined(PETSC_USE_COMPLEX)
    640:     PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("O","N",&m,&n,temp2,&lda,sigma,NULL,&ldu,NULL,&ldvt,work,&lwork,rwork,&info));
    641: #else
    642:     PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("O","N",&m,&n,temp2,&lda,sigma,NULL,&ldu,NULL,&ldvt,work,&lwork,&info));
    643: #endif
    644:     if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xGESVD %d",info);

    646:     PetscBLASIntCast(local_size,&l);
    647:     PetscBLASIntCast(ml,&n);
    648:     m = n; lda = l; ldb = m; ldc = l;
    649:     if (k==0) {
    650:       PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&l,&n,&m,&alpha,s_data,&lda,temp2,&ldb,&beta,Q1,&ldc));
    651:     } else if ((k%2)==1) {
    652:       PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&l,&n,&m,&alpha,Q1,&lda,temp2,&ldb,&beta,Q2,&ldc));
    653:     } else {
    654:       PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&l,&n,&m,&alpha,Q2,&lda,temp2,&ldb,&beta,Q1,&ldc));
    655:     }

    657:     PetscBLASIntCast(ml,&l);
    658:     m = l; n = l; lda = l; ldb = m; ldc = l;
    659:     PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&l,&n,&m,&alpha,B,&lda,temp2,&ldb,&beta,tempB,&ldc));
    660:     for (i=0;i<ml;i++) {
    661:       sigma[i] = sqrt(sigma[i]);
    662:       for (j=0;j<local_size;j++) {
    663:         if ((k%2)==1) Q2[j+i*local_size]/=sigma[i];
    664:         else Q1[j+i*local_size]/=sigma[i];
    665:       }
    666:       for (j=0;j<ml;j++) {
    667:         B[j+i*ml]=tempB[j+i*ml]*sigma[i];
    668:       }
    669:     }
    670:   }

    672:   PetscBLASIntCast(ml,&m);
    673:   n = m; lda = m; ldu=1; ldvt=1;
    674: #if defined(PETSC_USE_COMPLEX)
    675:   PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("N","O",&m,&n,B,&lda,sigma,NULL,&ldu,NULL,&ldvt,work,&lwork,rwork,&info));
    676: #else
    677:   PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("N","O",&m,&n,B,&lda,sigma,NULL,&ldu,NULL,&ldvt,work,&lwork,&info));
    678: #endif
    679:   if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xGESVD %d",info);

    681:   PetscBLASIntCast(local_size,&l);
    682:   PetscBLASIntCast(ml,&n);
    683:   m = n; lda = l; ldb = m; ldc = l;
    684:   if ((k%2)==1) {
    685:     PetscStackCallBLAS("BLASgemm",BLASgemm_("N","T",&l,&n,&m,&alpha,Q1,&lda,B,&ldb,&beta,s_data,&ldc));
    686:   } else {
    687:     PetscStackCallBLAS("BLASgemm",BLASgemm_("N","T",&l,&n,&m,&alpha,Q2,&lda,B,&ldb,&beta,s_data,&ldc));
    688:   }

    690:   PetscFPTrapPop();
    691:   BVRestoreArray(S,&s_data);

    693:   (*K) = 0;
    694:   for (i=0;i<ml;i++) {
    695:     if (sigma[i]/PetscMax(sigma[0],1)>delta) (*K)++;
    696:   }
    697:   PetscFree7(temp,temp2,Q1,Q2,B,tempB,work);
    698: #if defined(PETSC_USE_COMPLEX)
    699:   PetscFree(rwork);
    700: #endif
    701:   return(0);
    702: #endif
    703: }

    707: static PetscErrorCode isGhost(EPS eps,PetscInt ld,PetscInt nv,PetscBool *fl)
    708: {
    710:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    711:   PetscInt       i,j;
    712:   PetscScalar    *pX;
    713:   PetscReal      *tau,s1,s2,tau_max=0.0;

    716:   PetscMalloc1(nv,&tau);
    717:   DSVectors(eps->ds,DS_MAT_X,NULL,NULL);
    718:   DSGetArray(eps->ds,DS_MAT_X,&pX);

    720:   for (i=0;i<nv;i++) {
    721:     s1 = 0;
    722:     s2 = 0;
    723:     for (j=0;j<nv;j++) {
    724:       s1 += PetscAbsScalar(PetscPowScalarInt(pX[i*ld+j],2));
    725:       s2 += PetscPowRealInt(PetscAbsScalar(pX[i*ld+j]),2)/ctx->sigma[j];
    726:     }
    727:     tau[i] = s1/s2;
    728:     tau_max = PetscMax(tau_max,tau[i]);
    729:   }
    730:   DSRestoreArray(eps->ds,DS_MAT_X,&pX);
    731:   for (i=0;i<nv;i++) {
    732:     tau[i] /= tau_max;
    733:   }
    734:   for (i=0;i<nv;i++) {
    735:     if (tau[i]>=ctx->spurious_threshold) fl[i] = PETSC_TRUE;
    736:     else fl[i] = PETSC_FALSE;
    737:   }
    738:   PetscFree(tau);
    739:   return(0);
    740: }

    744: static PetscErrorCode rescale_eig(EPS eps,PetscInt nv)
    745: {
    747:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    748:   PetscInt       i;
    749:   PetscScalar    center;
    750:   PetscReal      radius,a,b,c,d,rgscale;
    751: #if defined(PETSC_USE_COMPLEX)
    752:   PetscReal      start_ang,end_ang,vscale,theta;
    753: #endif
    754:   PetscBool      isring,isellipse,isinterval;

    757:   PetscObjectTypeCompare((PetscObject)eps->rg,RGELLIPSE,&isellipse);
    758:   PetscObjectTypeCompare((PetscObject)eps->rg,RGRING,&isring);
    759:   PetscObjectTypeCompare((PetscObject)eps->rg,RGINTERVAL,&isinterval);
    760:   RGGetScale(eps->rg,&rgscale);
    761:   if (isinterval) {
    762:     RGIntervalGetEndpoints(eps->rg,NULL,NULL,&c,&d);
    763:     if (c==d) {
    764:       for (i=0;i<nv;i++) {
    765: #if defined(PETSC_USE_COMPLEX)
    766:         eps->eigr[i] = PetscRealPart(eps->eigr[i]);
    767: #else
    768:         eps->eigi[i] = 0;
    769: #endif
    770:       }
    771:     }
    772:   }
    773:   if (ctx->extraction == EPS_CISS_EXTRACTION_HANKEL) {
    774:     if (isellipse) {
    775:       RGEllipseGetParameters(eps->rg,&center,&radius,NULL);
    776:       for (i=0;i<nv;i++) eps->eigr[i] = rgscale*(center + radius*eps->eigr[i]);
    777:     } else if (isinterval) {
    778:       RGIntervalGetEndpoints(eps->rg,&a,&b,&c,&d);
    779:       if (ctx->quad == EPS_CISS_QUADRULE_CHEBYSHEV) {
    780:         for (i=0;i<nv;i++) {
    781:           if (c==d) eps->eigr[i] = ((b-a)*(eps->eigr[i]+1.0)/2.0+a)*rgscale;
    782:           if (a==b) {
    783: #if defined(PETSC_USE_COMPLEX)
    784:             eps->eigr[i] = ((d-c)*(eps->eigr[i]+1.0)/2.0+c)*rgscale*PETSC_i;
    785: #else
    786:             SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Integration points on a vertical line require complex arithmetic");
    787: #endif
    788:           }
    789:         }
    790:       } else {
    791:         center = (b+a)/2.0+(d+c)/2.0*PETSC_PI;
    792:         radius = PetscSqrtReal(PetscPowRealInt((b-a)/2.0,2)+PetscPowRealInt((d-c)/2.0,2));
    793:         for (i=0;i<nv;i++) eps->eigr[i] = center + radius*eps->eigr[i];
    794:       }
    795:     } else if (isring) {  /* only supported in complex scalars */
    796: #if defined(PETSC_USE_COMPLEX)
    797:       RGRingGetParameters(eps->rg,&center,&radius,&vscale,&start_ang,&end_ang,NULL);
    798:       if (ctx->quad == EPS_CISS_QUADRULE_CHEBYSHEV) {
    799:         for (i=0;i<nv;i++) {
    800:           theta = (start_ang*2.0+(end_ang-start_ang)*(PetscRealPart(eps->eigr[i])+1.0))*PETSC_PI;
    801:           eps->eigr[i] = rgscale*center + (rgscale*radius+PetscImaginaryPart(eps->eigr[i]))*(PetscCosReal(theta)+PETSC_i*vscale*PetscSinReal(theta));
    802:         }
    803:       } else {
    804:         for (i=0;i<nv;i++) eps->eigr[i] = rgscale*(center + radius*eps->eigr[i]);
    805:       }
    806: #endif
    807:     }
    808:   }
    809:   return(0);
    810: }

    814: PetscErrorCode EPSSetUp_CISS(EPS eps)
    815: {
    817:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    818:   PetscInt       i;
    819:   PetscBool      issinvert,istrivial,isring,isellipse,isinterval,flg;
    820:   PetscScalar    center;
    821:   PetscReal      c,d;
    822:   Mat            A;

    825:   if (!eps->ncv) eps->ncv = ctx->L_max*ctx->M;
    826:   else {
    827:     EPSSetDimensions_Default(eps,eps->nev,&eps->ncv,&eps->mpd);
    828:     ctx->L_max = eps->ncv/ctx->M;
    829:     if (ctx->L_max == 0) {
    830:       ctx->L_max = 1;
    831:       eps->ncv = ctx->L_max*ctx->M;
    832:     }
    833:     if (ctx->L > ctx->L_max) ctx->L = ctx->L_max;
    834:   }
    835:   if (!eps->max_it) eps->max_it = 1;
    836:   if (!eps->mpd) eps->mpd = eps->ncv;
    837:   if (!eps->which) eps->which = EPS_ALL;
    838:   if (!eps->extraction) { EPSSetExtraction(eps,EPS_RITZ); }
    839:   else if (eps->extraction!=EPS_RITZ) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_SUP,"Unsupported extraction type");
    840:   if (eps->arbitrary) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_SUP,"Arbitrary selection of eigenpairs not supported in this solver");
    841:   if (eps->stopping!=EPSStoppingBasic) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_SUP,"This solver does not support user-defined stopping test");
    842:   /* check region */
    843:   RGIsTrivial(eps->rg,&istrivial);
    844:   if (istrivial) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_SUP,"CISS requires a nontrivial region, e.g. -rg_type ellipse ...");
    845:   RGGetComplement(eps->rg,&flg);
    846:   if (flg) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_SUP,"A region with complement flag set is not allowed");
    847:   PetscObjectTypeCompare((PetscObject)eps->rg,RGELLIPSE,&isellipse);
    848:   PetscObjectTypeCompare((PetscObject)eps->rg,RGRING,&isring);
    849:   PetscObjectTypeCompare((PetscObject)eps->rg,RGINTERVAL,&isinterval);
    850:   if (!isellipse && !isring && !isinterval) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_SUP,"Currently only implemented for interval, elliptic or ring regions");
    851:   if (isring) {
    852: #if !defined(PETSC_USE_COMPLEX)
    853:     SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_SUP,"Ring region only supported for complex scalars");
    854: #endif
    855:     ctx->useconj = PETSC_FALSE;
    856:   }
    857:   if (isellipse) {
    858:     RGEllipseGetParameters(eps->rg,&center,NULL,NULL);
    859: #if defined(PETSC_USE_COMPLEX)
    860:     if (ctx->isreal && PetscImaginaryPart(center) == 0.0) ctx->useconj = PETSC_TRUE;
    861:     else ctx->useconj = PETSC_FALSE;
    862: #else
    863:     ctx->useconj = PETSC_FALSE;
    864: #endif
    865:   }
    866:   if (isinterval) {
    867:     RGIntervalGetEndpoints(eps->rg,NULL,NULL,&c,&d);
    868: #if defined(PETSC_USE_COMPLEX)
    869:     if (ctx->isreal && c==d) ctx->useconj = PETSC_TRUE;
    870:     else ctx->useconj = PETSC_FALSE;
    871: #else
    872:     if (c!=d || c!=0.0) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_SUP,"In real scalars, endpoints of the imaginary axis must be both zero");
    873:     ctx->useconj = PETSC_FALSE;
    874: #endif
    875:     if (!ctx->quad && c==d) ctx->quad = EPS_CISS_QUADRULE_CHEBYSHEV;
    876:   }
    877:   if (!ctx->quad) ctx->quad = EPS_CISS_QUADRULE_TRAPEZOIDAL;
    878:   /* create split comm */
    879:   SetSolverComm(eps);

    881:   EPSAllocateSolution(eps,0);
    882:   PetscMalloc4(ctx->N,&ctx->weight,ctx->N+1,&ctx->omega,ctx->N,&ctx->pp,ctx->L_max*ctx->M,&ctx->sigma);
    883:   PetscLogObjectMemory((PetscObject)eps,3*ctx->N*sizeof(PetscScalar)+ctx->L_max*ctx->N*sizeof(PetscReal));

    885:   /* allocate basis vectors */
    886:   BVDuplicateResize(eps->V,ctx->L_max*ctx->M,&ctx->S);
    887:   PetscLogObjectParent((PetscObject)eps,(PetscObject)ctx->S);
    888:   BVDuplicateResize(eps->V,ctx->L_max,&ctx->V);
    889:   PetscLogObjectParent((PetscObject)eps,(PetscObject)ctx->V);

    891:   STGetOperators(eps->st,0,&A);
    892:   PetscObjectTypeCompare((PetscObject)A,MATSHELL,&flg);
    893:   if (flg) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_SUP,"Matrix type shell is not supported in this solver");

    895:   if (!ctx->usest_set) ctx->usest = (ctx->num_subcomm>1)? PETSC_FALSE: PETSC_TRUE;
    896:   if (ctx->usest && ctx->num_subcomm>1) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_SUP,"The usest flag is not supported when partitions > 1");

    898:   CISSRedundantMat(eps);
    899:   if (ctx->pA) {
    900:     CISSScatterVec(eps);
    901:     BVCreate(PetscObjectComm((PetscObject)ctx->xsub),&ctx->pV);
    902:     BVSetSizesFromVec(ctx->pV,ctx->xsub,eps->n);
    903:     BVSetFromOptions(ctx->pV);
    904:     BVResize(ctx->pV,ctx->L_max,PETSC_FALSE);
    905:     PetscLogObjectParent((PetscObject)eps,(PetscObject)ctx->pV);
    906:   }

    908:   if (ctx->usest) {
    909:     PetscObjectTypeCompare((PetscObject)eps->st,STSINVERT,&issinvert);
    910:     if (!issinvert) { STSetType(eps->st,STSINVERT); }
    911:   } else {
    912:     STSetType(eps->st,STSHIFT);  /* we are not going to use ST, so avoid problems in case the user provided one */
    913:     PetscMalloc2(ctx->num_solve_point,&ctx->ksp,ctx->num_solve_point,&ctx->kspMat);
    914:     PetscLogObjectMemory((PetscObject)eps,ctx->num_solve_point*sizeof(KSP)+ctx->num_solve_point*sizeof(Mat));
    915:     for (i=0;i<ctx->num_solve_point;i++) {
    916:       KSPCreate(PetscSubcommChild(ctx->subcomm),&ctx->ksp[i]);
    917:       PetscObjectIncrementTabLevel((PetscObject)ctx->ksp[i],(PetscObject)eps,1);
    918:       PetscLogObjectParent((PetscObject)eps,(PetscObject)ctx->ksp[i]);
    919:       KSPSetOptionsPrefix(ctx->ksp[i],((PetscObject)eps)->prefix);
    920:       KSPAppendOptionsPrefix(ctx->ksp[i],"eps_ciss_");
    921:       KSPSetErrorIfNotConverged(ctx->ksp[i],PETSC_TRUE);
    922:     }
    923:   }

    925:   if (ctx->pA) {
    926:     BVCreate(PetscObjectComm((PetscObject)ctx->xsub),&ctx->Y);
    927:     BVSetSizesFromVec(ctx->Y,ctx->xsub,eps->n);
    928:     BVSetFromOptions(ctx->Y);
    929:     BVResize(ctx->Y,ctx->num_solve_point*ctx->L_max,PETSC_FALSE);
    930:   } else {
    931:     BVDuplicateResize(eps->V,ctx->num_solve_point*ctx->L_max,&ctx->Y);
    932:   }
    933:   PetscLogObjectParent((PetscObject)eps,(PetscObject)ctx->Y);

    935:   if (ctx->extraction == EPS_CISS_EXTRACTION_HANKEL) {
    936:     DSSetType(eps->ds,DSGNHEP);
    937:   } else if (eps->isgeneralized) {
    938:     if (eps->ishermitian && eps->ispositive) {
    939:       DSSetType(eps->ds,DSGHEP);
    940:     } else {
    941:       DSSetType(eps->ds,DSGNHEP);
    942:     }
    943:   } else {
    944:     if (eps->ishermitian) {
    945:       DSSetType(eps->ds,DSHEP);
    946:     } else {
    947:       DSSetType(eps->ds,DSNHEP);
    948:     }
    949:   }
    950:   DSAllocate(eps->ds,eps->ncv);
    951:   EPSSetWorkVecs(eps,2);

    953:   /* In GHEP problems, deactivate purification to avoid losing
    954:      B-normalization of eigenvectors in EPSComputeVectors_Schur */
    955:   eps->purify = PETSC_FALSE;

    957: #if !defined(PETSC_USE_COMPLEX)
    958:   if (!eps->ishermitian) { PetscInfo(eps,"Warning: complex eigenvalues are not calculated exactly without --with-scalar-type=complex in PETSc\n"); }
    959: #endif
    960:   return(0);
    961: }

    965: PetscErrorCode EPSSolve_CISS(EPS eps)
    966: {
    968:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    969:   Mat            A,B,X,M,pA,pB;
    970:   PetscInt       i,j,ld,nmat,L_add=0,nv=0,L_base=ctx->L,inner,nlocal,*inside;
    971:   PetscScalar    *Mu,*H0,*H1=NULL,*rr,*temp;
    972:   PetscReal      error,max_error;
    973:   PetscBool      *fl1;
    974:   Vec            si,w[3];
    975:   SlepcSC        sc;
    976:   PetscRandom    rand;
    977: #if defined(PETSC_USE_COMPLEX)
    978:   PetscBool      isellipse;
    979: #endif

    982:   w[0] = eps->work[0];
    983:   w[1] = NULL;
    984:   w[2] = eps->work[1];
    985:   /* override SC settings */
    986:   DSGetSlepcSC(eps->ds,&sc);
    987:   sc->comparison    = SlepcCompareLargestMagnitude;
    988:   sc->comparisonctx = NULL;
    989:   sc->map           = NULL;
    990:   sc->mapobj        = NULL;
    991:   VecGetLocalSize(w[0],&nlocal);
    992:   DSGetLeadingDimension(eps->ds,&ld);
    993:   STGetNumMatrices(eps->st,&nmat);
    994:   STGetOperators(eps->st,0,&A);
    995:   if (nmat>1) { STGetOperators(eps->st,1,&B); }
    996:   else B = NULL;
    997:   SetPathParameter(eps);
    998:   CISSVecSetRandom(ctx->V,0,ctx->L);
    999:   BVGetRandomContext(ctx->V,&rand);

    1001:   if (ctx->pA) {
    1002:     VecScatterVecs(eps,ctx->V,ctx->L);
    1003:     SolveLinearSystem(eps,ctx->pA,ctx->pB,ctx->pV,0,ctx->L,PETSC_TRUE);
    1004:   } else {
    1005:     SolveLinearSystem(eps,A,B,ctx->V,0,ctx->L,PETSC_TRUE);
    1006:   }
    1007: #if defined(PETSC_USE_COMPLEX)
    1008:   PetscObjectTypeCompare((PetscObject)eps->rg,RGELLIPSE,&isellipse);
    1009:   if (isellipse) {
    1010:     EstimateNumberEigs(eps,&L_add);
    1011:   } else {
    1012:     L_add = 0;
    1013:   }
    1014: #else
    1015:   L_add = 0;
    1016: #endif
    1017:   if (L_add>0) {
    1018:     PetscInfo2(eps,"Changing L %D -> %D by Estimate #Eig\n",ctx->L,ctx->L+L_add);
    1019:     CISSVecSetRandom(ctx->V,ctx->L,ctx->L+L_add);
    1020:     if (ctx->pA) {
    1021:       VecScatterVecs(eps,ctx->V,ctx->L+L_add);
    1022:       SolveLinearSystem(eps,ctx->pA,ctx->pB,ctx->pV,ctx->L,ctx->L+L_add,PETSC_FALSE);
    1023:     } else {
    1024:       SolveLinearSystem(eps,A,B,ctx->V,ctx->L,ctx->L+L_add,PETSC_FALSE);
    1025:     }
    1026:     ctx->L += L_add;
    1027:   }
    1028:   PetscMalloc2(ctx->L*ctx->L*ctx->M*2,&Mu,ctx->L*ctx->M*ctx->L*ctx->M,&H0);
    1029:   for (i=0;i<ctx->refine_blocksize;i++) {
    1030:     CalcMu(eps,Mu);
    1031:     BlockHankel(eps,Mu,0,H0);
    1032:     SVD_H0(eps,H0,&nv);
    1033:     if (ctx->sigma[0]<=ctx->delta || nv < ctx->L*ctx->M || ctx->L == ctx->L_max) break;
    1034:     L_add = L_base;
    1035:     if (ctx->L+L_add>ctx->L_max) L_add = ctx->L_max-ctx->L;
    1036:     PetscInfo2(eps,"Changing L %D -> %D by SVD(H0)\n",ctx->L,ctx->L+L_add);
    1037:     CISSVecSetRandom(ctx->V,ctx->L,ctx->L+L_add);
    1038:     if (ctx->pA) {
    1039:       VecScatterVecs(eps,ctx->V,ctx->L+L_add);
    1040:       SolveLinearSystem(eps,ctx->pA,ctx->pB,ctx->pV,ctx->L,ctx->L+L_add,PETSC_FALSE);
    1041:     } else {
    1042:       SolveLinearSystem(eps,A,B,ctx->V,ctx->L,ctx->L+L_add,PETSC_FALSE);
    1043:     }
    1044:     ctx->L += L_add;
    1045:   }
    1046:   if (ctx->extraction == EPS_CISS_EXTRACTION_HANKEL) {
    1047:     PetscMalloc1(ctx->L*ctx->M*ctx->L*ctx->M,&H1);
    1048:   }

    1050:   while (eps->reason == EPS_CONVERGED_ITERATING) {
    1051:     eps->its++;
    1052:     for (inner=0;inner<=ctx->refine_inner;inner++) {
    1053:       if (ctx->extraction == EPS_CISS_EXTRACTION_HANKEL) {
    1054:         CalcMu(eps,Mu);
    1055:         BlockHankel(eps,Mu,0,H0);
    1056:         SVD_H0(eps,H0,&nv);
    1057:         break;
    1058:       } else {
    1059:         ConstructS(eps);
    1060:         BVSetActiveColumns(ctx->S,0,ctx->L);
    1061:         BVCopy(ctx->S,ctx->V);
    1062:         SVD_S(ctx->S,ctx->L*ctx->M,ctx->delta,ctx->sigma,&nv);
    1063:         if (ctx->sigma[0]>ctx->delta && nv==ctx->L*ctx->M && inner!=ctx->refine_inner) {
    1064:           if (ctx->pA) {
    1065:             VecScatterVecs(eps,ctx->V,ctx->L);
    1066:             SolveLinearSystem(eps,ctx->pA,ctx->pB,ctx->pV,0,ctx->L,PETSC_FALSE);
    1067:           } else {
    1068:             SolveLinearSystem(eps,A,B,ctx->V,0,ctx->L,PETSC_FALSE);
    1069:           }
    1070:         } else break;
    1071:       }
    1072:     }
    1073:     eps->nconv = 0;
    1074:     if (nv == 0) eps->reason = EPS_CONVERGED_TOL;
    1075:     else {
    1076:       DSSetDimensions(eps->ds,nv,0,0,0);
    1077:       DSSetState(eps->ds,DS_STATE_RAW);

    1079:       if (ctx->extraction == EPS_CISS_EXTRACTION_HANKEL) {
    1080:         BlockHankel(eps,Mu,0,H0);
    1081:         BlockHankel(eps,Mu,1,H1);
    1082:         DSGetArray(eps->ds,DS_MAT_A,&temp);
    1083:         for (j=0;j<nv;j++) {
    1084:           for (i=0;i<nv;i++) {
    1085:             temp[i+j*ld] = H1[i+j*ctx->L*ctx->M];
    1086:           }
    1087:         }
    1088:         DSRestoreArray(eps->ds,DS_MAT_A,&temp);
    1089:         DSGetArray(eps->ds,DS_MAT_B,&temp);
    1090:         for (j=0;j<nv;j++) {
    1091:           for (i=0;i<nv;i++) {
    1092:             temp[i+j*ld] = H0[i+j*ctx->L*ctx->M];
    1093:           }
    1094:         }
    1095:         DSRestoreArray(eps->ds,DS_MAT_B,&temp);
    1096:       } else {
    1097:         BVSetActiveColumns(ctx->S,0,nv);
    1098:         DSGetMat(eps->ds,DS_MAT_A,&pA);
    1099:         MatZeroEntries(pA);
    1100:         BVMatProject(ctx->S,A,ctx->S,pA);
    1101:         DSRestoreMat(eps->ds,DS_MAT_A,&pA);
    1102:         if (B) {
    1103:           DSGetMat(eps->ds,DS_MAT_B,&pB);
    1104:           MatZeroEntries(pB);
    1105:           BVMatProject(ctx->S,B,ctx->S,pB);
    1106:           DSRestoreMat(eps->ds,DS_MAT_B,&pB);
    1107:         }
    1108:       }

    1110:       DSSolve(eps->ds,eps->eigr,eps->eigi);
    1111:       DSVectors(eps->ds,DS_MAT_X,NULL,NULL);

    1113:       PetscMalloc3(nv,&fl1,nv,&inside,nv,&rr);
    1114:       rescale_eig(eps,nv);
    1115:       isGhost(eps,ld,nv,fl1);
    1116:       RGCheckInside(eps->rg,nv,eps->eigr,eps->eigi,inside);
    1117:       for (i=0;i<nv;i++) {
    1118:         if (fl1[i] && inside[i]>=0) {
    1119:           rr[i] = 1.0;
    1120:           eps->nconv++;
    1121:         } else rr[i] = 0.0;
    1122:       }
    1123:       DSSort(eps->ds,eps->eigr,eps->eigi,rr,NULL,&eps->nconv);
    1124:       rescale_eig(eps,nv);
    1125:       PetscFree3(fl1,inside,rr);
    1126:       BVSetActiveColumns(eps->V,0,nv);
    1127:       if (ctx->extraction == EPS_CISS_EXTRACTION_HANKEL) {
    1128:         ConstructS(eps);
    1129:         BVSetActiveColumns(ctx->S,0,ctx->L);
    1130:         BVCopy(ctx->S,ctx->V);
    1131:         BVSetActiveColumns(ctx->S,0,nv);
    1132:       }
    1133:       BVCopy(ctx->S,eps->V);

    1135:       DSVectors(eps->ds,DS_MAT_X,NULL,NULL);
    1136:       DSGetMat(eps->ds,DS_MAT_X,&X);
    1137:       BVMultInPlace(ctx->S,X,0,eps->nconv);
    1138:       if (eps->ishermitian) {
    1139:         BVMultInPlace(eps->V,X,0,eps->nconv);
    1140:       }
    1141:       MatDestroy(&X);
    1142:       max_error = 0.0;
    1143:       for (i=0;i<eps->nconv;i++) {
    1144:         BVGetColumn(ctx->S,i,&si);
    1145:         EPSComputeResidualNorm_Private(eps,eps->eigr[i],eps->eigi[i],si,NULL,w,&error);
    1146:         (*eps->converged)(eps,eps->eigr[i],eps->eigi[i],error,&error,eps->convergedctx);
    1147:         BVRestoreColumn(ctx->S,i,&si);
    1148:         max_error = PetscMax(max_error,error);
    1149:       }

    1151:       if (max_error <= eps->tol) eps->reason = EPS_CONVERGED_TOL;
    1152:       else if (eps->its >= eps->max_it) eps->reason = EPS_DIVERGED_ITS;
    1153:       else {
    1154:         if (eps->nconv > ctx->L) {
    1155:           MatCreateSeqDense(PETSC_COMM_SELF,eps->nconv,ctx->L,NULL,&M);
    1156:           MatDenseGetArray(M,&temp);
    1157:           for (i=0;i<ctx->L*eps->nconv;i++) {
    1158:             PetscRandomGetValue(rand,&temp[i]);
    1159:             temp[i] = PetscRealPart(temp[i]);
    1160:           }
    1161:           MatDenseRestoreArray(M,&temp);
    1162:           BVSetActiveColumns(ctx->S,0,eps->nconv);
    1163:           BVMultInPlace(ctx->S,M,0,ctx->L);
    1164:           MatDestroy(&M);
    1165:           BVSetActiveColumns(ctx->S,0,ctx->L);
    1166:           BVCopy(ctx->S,ctx->V);
    1167:         }
    1168:         if (ctx->pA) {
    1169:           VecScatterVecs(eps,ctx->V,ctx->L);
    1170:           SolveLinearSystem(eps,ctx->pA,ctx->pB,ctx->pV,0,ctx->L,PETSC_FALSE);
    1171:         } else {
    1172:           SolveLinearSystem(eps,A,B,ctx->V,0,ctx->L,PETSC_FALSE);
    1173:         }
    1174:       }
    1175:     }
    1176:   }
    1177:   if (ctx->extraction == EPS_CISS_EXTRACTION_HANKEL) {
    1178:     PetscFree(H1);
    1179:   }
    1180:   PetscFree2(Mu,H0);
    1181:   return(0);
    1182: }

    1186: static PetscErrorCode EPSCISSSetSizes_CISS(EPS eps,PetscInt ip,PetscInt bs,PetscInt ms,PetscInt npart,PetscInt bsmax,PetscBool realmats)
    1187: {
    1189:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;

    1192:   if (ip == PETSC_DECIDE || ip == PETSC_DEFAULT) {
    1193:     if (ctx->N!=32) { ctx->N =32; ctx->M = ctx->N/4; }
    1194:   } else {
    1195:     if (ip<1) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_ARG_OUTOFRANGE,"The ip argument must be > 0");
    1196:     if (ip%2) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_ARG_OUTOFRANGE,"The ip argument must be an even number");
    1197:     if (ctx->N!=ip) { ctx->N = ip; ctx->M = ctx->N/4; }
    1198:   }
    1199:   if (bs == PETSC_DECIDE || bs == PETSC_DEFAULT) {
    1200:     ctx->L = 16;
    1201:   } else {
    1202:     if (bs<1) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_ARG_OUTOFRANGE,"The bs argument must be > 0");
    1203:     if (bs>ctx->L_max) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_ARG_OUTOFRANGE,"The bs argument must be less than or equal to the maximum number of block size");
    1204:     ctx->L = bs;
    1205:   }
    1206:   if (ms == PETSC_DECIDE || ms == PETSC_DEFAULT) {
    1207:     ctx->M = ctx->N/4;
    1208:   } else {
    1209:     if (ms<1) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_ARG_OUTOFRANGE,"The ms argument must be > 0");
    1210:     if (ms>ctx->N) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_ARG_OUTOFRANGE,"The ms argument must be less than or equal to the number of integration points");
    1211:     ctx->M = ms;
    1212:   }
    1213:   if (npart == PETSC_DECIDE || npart == PETSC_DEFAULT) {
    1214:     ctx->num_subcomm = 1;
    1215:   } else {
    1216:     if (npart<1) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_ARG_OUTOFRANGE,"The npart argument must be > 0");
    1217:     ctx->num_subcomm = npart;
    1218:   }
    1219:   if (bsmax == PETSC_DECIDE || bsmax == PETSC_DEFAULT) {
    1220:     ctx->L = 256;
    1221:   } else {
    1222:     if (bsmax<1) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_ARG_OUTOFRANGE,"The bsmax argument must be > 0");
    1223:     if (bsmax<ctx->L) ctx->L_max = ctx->L;
    1224:     else ctx->L_max = bsmax;
    1225:   }
    1226:   ctx->isreal = realmats;
    1227:   EPSReset(eps);   /* clean allocated arrays and force new setup */
    1228:   return(0);
    1229: }

    1233: /*@
    1234:    EPSCISSSetSizes - Sets the values of various size parameters in the CISS solver.

    1236:    Logically Collective on EPS

    1238:    Input Parameters:
    1239: +  eps   - the eigenproblem solver context
    1240: .  ip    - number of integration points
    1241: .  bs    - block size
    1242: .  ms    - moment size
    1243: .  npart - number of partitions when splitting the communicator
    1244: .  bsmax - max block size
    1245: -  realmats - A and B are real

    1247:    Options Database Keys:
    1248: +  -eps_ciss_integration_points - Sets the number of integration points
    1249: .  -eps_ciss_blocksize - Sets the block size
    1250: .  -eps_ciss_moments - Sets the moment size
    1251: .  -eps_ciss_partitions - Sets the number of partitions
    1252: .  -eps_ciss_maxblocksize - Sets the maximum block size
    1253: -  -eps_ciss_realmats - A and B are real

    1255:    Note:
    1256:    The default number of partitions is 1. This means the internal KSP object is shared
    1257:    among all processes of the EPS communicator. Otherwise, the communicator is split
    1258:    into npart communicators, so that npart KSP solves proceed simultaneously.

    1260:    Level: advanced

    1262: .seealso: EPSCISSGetSizes()
    1263: @*/
    1264: PetscErrorCode EPSCISSSetSizes(EPS eps,PetscInt ip,PetscInt bs,PetscInt ms,PetscInt npart,PetscInt bsmax,PetscBool realmats)
    1265: {

    1276:   PetscTryMethod(eps,"EPSCISSSetSizes_C",(EPS,PetscInt,PetscInt,PetscInt,PetscInt,PetscInt,PetscBool),(eps,ip,bs,ms,npart,bsmax,realmats));
    1277:   return(0);
    1278: }

    1282: static PetscErrorCode EPSCISSGetSizes_CISS(EPS eps,PetscInt *ip,PetscInt *bs,PetscInt *ms,PetscInt *npart,PetscInt *bsmax,PetscBool *realmats)
    1283: {
    1284:   EPS_CISS *ctx = (EPS_CISS*)eps->data;

    1287:   if (ip) *ip = ctx->N;
    1288:   if (bs) *bs = ctx->L;
    1289:   if (ms) *ms = ctx->M;
    1290:   if (npart) *npart = ctx->num_subcomm;
    1291:   if (bsmax) *bsmax = ctx->L_max;
    1292:   if (realmats) *realmats = ctx->isreal;
    1293:   return(0);
    1294: }

    1298: /*@
    1299:    EPSCISSGetSizes - Gets the values of various size parameters in the CISS solver.

    1301:    Not Collective

    1303:    Input Parameter:
    1304: .  eps - the eigenproblem solver context

    1306:    Output Parameters:
    1307: +  ip    - number of integration points
    1308: .  bs    - block size
    1309: .  ms    - moment size
    1310: .  npart - number of partitions when splitting the communicator
    1311: .  bsmax - max block size
    1312: -  realmats - A and B are real

    1314:    Level: advanced

    1316: .seealso: EPSCISSSetSizes()
    1317: @*/
    1318: PetscErrorCode EPSCISSGetSizes(EPS eps,PetscInt *ip,PetscInt *bs,PetscInt *ms,PetscInt *npart,PetscInt *bsmax,PetscBool *realmats)
    1319: {

    1324:   PetscUseMethod(eps,"EPSCISSGetSizes_C",(EPS,PetscInt*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,PetscBool*),(eps,ip,bs,ms,npart,bsmax,realmats));
    1325:   return(0);
    1326: }

    1330: static PetscErrorCode EPSCISSSetThreshold_CISS(EPS eps,PetscReal delta,PetscReal spur)
    1331: {
    1332:   EPS_CISS *ctx = (EPS_CISS*)eps->data;

    1335:   if (delta == PETSC_DEFAULT) {
    1336:     ctx->delta = 1e-12;
    1337:   } else {
    1338:     if (delta<=0.0) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_ARG_OUTOFRANGE,"The delta argument must be > 0.0");
    1339:     ctx->delta = delta;
    1340:   }
    1341:   if (spur == PETSC_DEFAULT) {
    1342:     ctx->spurious_threshold = 1e-4;
    1343:   } else {
    1344:     if (spur<=0.0) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_ARG_OUTOFRANGE,"The spurious threshold argument must be > 0.0");
    1345:     ctx->spurious_threshold = spur;
    1346:   }
    1347:   return(0);
    1348: }

    1352: /*@
    1353:    EPSCISSSetThreshold - Sets the values of various threshold parameters in
    1354:    the CISS solver.

    1356:    Logically Collective on EPS

    1358:    Input Parameters:
    1359: +  eps   - the eigenproblem solver context
    1360: .  delta - threshold for numerical rank
    1361: -  spur  - spurious threshold (to discard spurious eigenpairs)

    1363:    Options Database Keys:
    1364: +  -eps_ciss_delta - Sets the delta
    1365: -  -eps_ciss_spurious_threshold - Sets the spurious threshold

    1367:    Level: advanced

    1369: .seealso: EPSCISSGetThreshold()
    1370: @*/
    1371: PetscErrorCode EPSCISSSetThreshold(EPS eps,PetscReal delta,PetscReal spur)
    1372: {

    1379:   PetscTryMethod(eps,"EPSCISSSetThreshold_C",(EPS,PetscReal,PetscReal),(eps,delta,spur));
    1380:   return(0);
    1381: }

    1385: static PetscErrorCode EPSCISSGetThreshold_CISS(EPS eps,PetscReal *delta,PetscReal *spur)
    1386: {
    1387:   EPS_CISS *ctx = (EPS_CISS*)eps->data;

    1390:   if (delta) *delta = ctx->delta;
    1391:   if (spur)  *spur = ctx->spurious_threshold;
    1392:   return(0);
    1393: }

    1397: /*@
    1398:    EPSCISSGetThreshold - Gets the values of various threshold parameters
    1399:    in the CISS solver.

    1401:    Not Collective

    1403:    Input Parameter:
    1404: .  eps - the eigenproblem solver context

    1406:    Output Parameters:
    1407: +  delta - threshold for numerical rank
    1408: -  spur  - spurious threshold (to discard spurious eigenpairs)

    1410:    Level: advanced

    1412: .seealso: EPSCISSSetThreshold()
    1413: @*/
    1414: PetscErrorCode EPSCISSGetThreshold(EPS eps,PetscReal *delta,PetscReal *spur)
    1415: {

    1420:   PetscUseMethod(eps,"EPSCISSGetThreshold_C",(EPS,PetscReal*,PetscReal*),(eps,delta,spur));
    1421:   return(0);
    1422: }

    1426: static PetscErrorCode EPSCISSSetRefinement_CISS(EPS eps,PetscInt inner,PetscInt blsize)
    1427: {
    1428:   EPS_CISS *ctx = (EPS_CISS*)eps->data;

    1431:   if (inner == PETSC_DEFAULT) {
    1432:     ctx->refine_inner = 0;
    1433:   } else {
    1434:     if (inner<0) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_ARG_OUTOFRANGE,"The refine inner argument must be >= 0");
    1435:     ctx->refine_inner = inner;
    1436:   }
    1437:   if (blsize == PETSC_DEFAULT) {
    1438:     ctx->refine_blocksize = 0;
    1439:   } else {
    1440:     if (blsize<0) SETERRQ(PetscObjectComm((PetscObject)eps),PETSC_ERR_ARG_OUTOFRANGE,"The refine blocksize argument must be >= 0");
    1441:     ctx->refine_blocksize = blsize;
    1442:   }
    1443:   return(0);
    1444: }

    1448: /*@
    1449:    EPSCISSSetRefinement - Sets the values of various refinement parameters
    1450:    in the CISS solver.

    1452:    Logically Collective on EPS

    1454:    Input Parameters:
    1455: +  eps    - the eigenproblem solver context
    1456: .  inner  - number of iterative refinement iterations (inner loop)
    1457: -  blsize - number of iterative refinement iterations (blocksize loop)

    1459:    Options Database Keys:
    1460: +  -eps_ciss_refine_inner - Sets number of inner iterations
    1461: -  -eps_ciss_refine_blocksize - Sets number of blocksize iterations

    1463:    Level: advanced

    1465: .seealso: EPSCISSGetRefinement()
    1466: @*/
    1467: PetscErrorCode EPSCISSSetRefinement(EPS eps,PetscInt inner,PetscInt blsize)
    1468: {

    1475:   PetscTryMethod(eps,"EPSCISSSetRefinement_C",(EPS,PetscInt,PetscInt),(eps,inner,blsize));
    1476:   return(0);
    1477: }

    1481: static PetscErrorCode EPSCISSGetRefinement_CISS(EPS eps,PetscInt *inner,PetscInt *blsize)
    1482: {
    1483:   EPS_CISS *ctx = (EPS_CISS*)eps->data;

    1486:   if (inner)  *inner = ctx->refine_inner;
    1487:   if (blsize) *blsize = ctx->refine_blocksize;
    1488:   return(0);
    1489: }

    1493: /*@
    1494:    EPSCISSGetRefinement - Gets the values of various refinement parameters
    1495:    in the CISS solver.

    1497:    Not Collective

    1499:    Input Parameter:
    1500: .  eps - the eigenproblem solver context

    1502:    Output Parameters:
    1503: +  inner  - number of iterative refinement iterations (inner loop)
    1504: -  blsize - number of iterative refinement iterations (blocksize loop)

    1506:    Level: advanced

    1508: .seealso: EPSCISSSetRefinement()
    1509: @*/
    1510: PetscErrorCode EPSCISSGetRefinement(EPS eps, PetscInt *inner, PetscInt *blsize)
    1511: {

    1516:   PetscUseMethod(eps,"EPSCISSGetRefinement_C",(EPS,PetscInt*,PetscInt*),(eps,inner,blsize));
    1517:   return(0);
    1518: }

    1522: static PetscErrorCode EPSCISSSetUseST_CISS(EPS eps,PetscBool usest)
    1523: {
    1524:   EPS_CISS *ctx = (EPS_CISS*)eps->data;

    1527:   ctx->usest     = usest;
    1528:   ctx->usest_set = PETSC_TRUE;
    1529:   return(0);
    1530: }

    1534: /*@
    1535:    EPSCISSSetUseST - Sets a flag indicating that the CISS solver will
    1536:    use the ST object for the linear solves.

    1538:    Logically Collective on EPS

    1540:    Input Parameters:
    1541: +  eps    - the eigenproblem solver context
    1542: -  usest  - boolean flag to use the ST object or not

    1544:    Options Database Keys:
    1545: .  -eps_ciss_usest <bool> - whether the ST object will be used or not

    1547:    Level: advanced

    1549: .seealso: EPSCISSGetUseST()
    1550: @*/
    1551: PetscErrorCode EPSCISSSetUseST(EPS eps,PetscBool usest)
    1552: {

    1558:   PetscTryMethod(eps,"EPSCISSSetUseST_C",(EPS,PetscBool),(eps,usest));
    1559:   return(0);
    1560: }

    1564: static PetscErrorCode EPSCISSGetUseST_CISS(EPS eps,PetscBool *usest)
    1565: {
    1566:   EPS_CISS *ctx = (EPS_CISS*)eps->data;

    1569:   *usest = ctx->usest;
    1570:   return(0);
    1571: }

    1575: /*@
    1576:    EPSCISSGetUseST - Gets the flag for using the ST object
    1577:    in the CISS solver.

    1579:    Not Collective

    1581:    Input Parameter:
    1582: .  eps - the eigenproblem solver context

    1584:    Output Parameters:
    1585: .  usest - boolean flag indicating if the ST object is being used

    1587:    Level: advanced

    1589: .seealso: EPSCISSSetUseST()
    1590: @*/
    1591: PetscErrorCode EPSCISSGetUseST(EPS eps,PetscBool *usest)
    1592: {

    1598:   PetscUseMethod(eps,"EPSCISSGetUseST_C",(EPS,PetscBool*),(eps,usest));
    1599:   return(0);
    1600: }

    1604: static PetscErrorCode EPSCISSSetQuadRule_CISS(EPS eps,EPSCISSQuadRule quad)
    1605: {
    1606:   EPS_CISS *ctx = (EPS_CISS*)eps->data;

    1609:   ctx->quad = quad;
    1610:   return(0);
    1611: }

    1615: /*@
    1616:    EPSCISSSetQuadRule - Sets the quadrature rule used in the CISS solver.

    1618:    Logically Collective on EPS

    1620:    Input Parameters:
    1621: +  eps  - the eigenproblem solver context
    1622: -  quad - the quadrature rule

    1624:    Options Database Key:
    1625: .  -eps_ciss_quadrule - Sets the quadrature rule (either 'trapezoidal' or
    1626:                            'chebyshev')

    1628:    Notes:
    1629:    By default, the trapezoidal rule is used (EPS_CISS_QUADRULE_TRAPEZOIDAL).

    1631:    If the 'chebyshev' option is specified (EPS_CISS_QUADRULE_CHEBYSHEV), then
    1632:    Chebyshev points are used as quadrature points.

    1634:    Level: advanced

    1636: .seealso: EPSCISSGetQuadRule(), EPSCISSQuadRule
    1637: @*/
    1638: PetscErrorCode EPSCISSSetQuadRule(EPS eps,EPSCISSQuadRule quad)
    1639: {

    1645:   PetscTryMethod(eps,"EPSCISSSetQuadRule_C",(EPS,EPSCISSQuadRule),(eps,quad));
    1646:   return(0);
    1647: }

    1651: static PetscErrorCode EPSCISSGetQuadRule_CISS(EPS eps,EPSCISSQuadRule *quad)
    1652: {
    1653:   EPS_CISS *ctx = (EPS_CISS*)eps->data;

    1656:   *quad = ctx->quad;
    1657:   return(0);
    1658: }

    1662: /*@
    1663:    EPSCISSGetQuadRule - Gets the quadrature rule used in the CISS solver.
    1664:
    1665:    Not Collective

    1667:    Input Parameter:
    1668: .  eps - the eigenproblem solver context

    1670:    Output Parameters:
    1671: .  quad - quadrature rule

    1673:    Level: advanced

    1675: .seealso: EPSCISSSetQuadRule() EPSCISSQuadRule
    1676: @*/
    1677: PetscErrorCode EPSCISSGetQuadRule(EPS eps, EPSCISSQuadRule *quad)
    1678: {

    1684:   PetscUseMethod(eps,"EPSCISSGetQuadRule_C",(EPS,EPSCISSQuadRule*),(eps,quad));
    1685:   return(0);
    1686: }

    1690: static PetscErrorCode EPSCISSSetExtraction_CISS(EPS eps,EPSCISSExtraction extraction)
    1691: {
    1692:   EPS_CISS *ctx = (EPS_CISS*)eps->data;

    1695:   ctx->extraction = extraction;
    1696:   return(0);
    1697: }

    1701: /*@
    1702:    EPSCISSSetExtraction - Sets the extraction technique used in the CISS solver.

    1704:    Logically Collective on EPS

    1706:    Input Parameters:
    1707: +  eps        - the eigenproblem solver context
    1708: -  extraction - the extraction technique

    1710:    Options Database Key:
    1711: .  -eps_ciss_extraction - Sets the extraction technique (either 'ritz' or
    1712:                            'hankel')

    1714:    Notes:
    1715:    By default, the Rayleigh-Ritz extraction is used (EPS_CISS_EXTRACTION_RITZ).

    1717:    If the 'hankel' option is specified (EPS_CISS_EXTRACTION_HANKEL), then
    1718:    the Block Hankel method is used for extracting eigenpairs.

    1720:    Level: advanced

    1722: .seealso: EPSCISSGetExtraction(), EPSCISSExtraction
    1723: @*/
    1724: PetscErrorCode EPSCISSSetExtraction(EPS eps,EPSCISSExtraction extraction)
    1725: {

    1731:   PetscTryMethod(eps,"EPSCISSSetExtraction_C",(EPS,EPSCISSExtraction),(eps,extraction));
    1732:   return(0);
    1733: }

    1737: static PetscErrorCode EPSCISSGetExtraction_CISS(EPS eps,EPSCISSExtraction *extraction)
    1738: {
    1739:   EPS_CISS *ctx = (EPS_CISS*)eps->data;

    1742:   *extraction = ctx->extraction;
    1743:   return(0);
    1744: }

    1748: /*@
    1749:    EPSCISSGetExtraction - Gets the extraction technique used in the CISS solver.

    1751:    Not Collective

    1753:    Input Parameter:
    1754: .  eps - the eigenproblem solver context

    1756:    Output Parameters:
    1757: +  extraction - extraction technique

    1759:    Level: advanced

    1761: .seealso: EPSCISSSetExtraction() EPSCISSExtraction
    1762: @*/
    1763: PetscErrorCode EPSCISSGetExtraction(EPS eps,EPSCISSExtraction *extraction)
    1764: {

    1770:   PetscUseMethod(eps,"EPSCISSGetExtraction_C",(EPS,EPSCISSExtraction*),(eps,extraction));
    1771:   return(0);
    1772: }

    1777: PetscErrorCode EPSReset_CISS(EPS eps)
    1778: {
    1780:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    1781:   PetscInt       i;

    1784:   PetscSubcommDestroy(&ctx->subcomm);
    1785:   PetscFree4(ctx->weight,ctx->omega,ctx->pp,ctx->sigma);
    1786:   BVDestroy(&ctx->S);
    1787:   BVDestroy(&ctx->V);
    1788:   BVDestroy(&ctx->Y);
    1789:   if (!ctx->usest) {
    1790:     for (i=0;i<ctx->num_solve_point;i++) {
    1791:       KSPDestroy(&ctx->ksp[i]);
    1792:     }
    1793:     for (i=0;i<ctx->num_solve_point;i++) {
    1794:       MatDestroy(&ctx->kspMat[i]);
    1795:     }
    1796:     PetscFree2(ctx->ksp,ctx->kspMat);
    1797:   }
    1798:   VecScatterDestroy(&ctx->scatterin);
    1799:   VecDestroy(&ctx->xsub);
    1800:   VecDestroy(&ctx->xdup);
    1801:   if (ctx->pA) {
    1802:     MatDestroy(&ctx->pA);
    1803:     MatDestroy(&ctx->pB);
    1804:     BVDestroy(&ctx->pV);
    1805:   }
    1806:   return(0);
    1807: }

    1811: PetscErrorCode EPSSetFromOptions_CISS(PetscOptionItems *PetscOptionsObject,EPS eps)
    1812: {
    1813:   PetscErrorCode    ierr;
    1814:   PetscReal         r3,r4;
    1815:   PetscInt          i1,i2,i3,i4,i5,i6,i7;
    1816:   PetscBool         b1,b2,flg;
    1817:   EPS_CISS          *ctx = (EPS_CISS*)eps->data;
    1818:   EPSCISSQuadRule   quad;
    1819:   EPSCISSExtraction extraction;

    1822:   PetscOptionsHead(PetscOptionsObject,"EPS CISS Options");
    1823:   EPSCISSGetSizes(eps,&i1,&i2,&i3,&i4,&i5,&b1);
    1824:   PetscOptionsInt("-eps_ciss_integration_points","CISS number of integration points","EPSCISSSetSizes",i1,&i1,NULL);
    1825:   PetscOptionsInt("-eps_ciss_blocksize","CISS block size","EPSCISSSetSizes",i2,&i2,NULL);
    1826:   PetscOptionsInt("-eps_ciss_moments","CISS moment size","EPSCISSSetSizes",i3,&i3,NULL);
    1827:   PetscOptionsInt("-eps_ciss_partitions","CISS number of partitions","EPSCISSSetSizes",i4,&i4,NULL);
    1828:   PetscOptionsInt("-eps_ciss_maxblocksize","CISS maximum block size","EPSCISSSetSizes",i5,&i5,NULL);
    1829:   PetscOptionsBool("-eps_ciss_realmats","CISS A and B are real","EPSCISSSetSizes",b1,&b1,NULL);
    1830:   EPSCISSSetSizes(eps,i1,i2,i3,i4,i5,b1);

    1832:   EPSCISSGetThreshold(eps,&r3,&r4);
    1833:   PetscOptionsReal("-eps_ciss_delta","CISS threshold for numerical rank","EPSCISSSetThreshold",r3,&r3,NULL);
    1834:   PetscOptionsReal("-eps_ciss_spurious_threshold","CISS threshold for the spurious eigenpairs","EPSCISSSetThreshold",r4,&r4,NULL);
    1835:   EPSCISSSetThreshold(eps,r3,r4);

    1837:   EPSCISSGetRefinement(eps,&i6,&i7);
    1838:   PetscOptionsInt("-eps_ciss_refine_inner","CISS number of inner iterative refinement iterations","EPSCISSSetRefinement",i6,&i6,NULL);
    1839:   PetscOptionsInt("-eps_ciss_refine_blocksize","CISS number of blocksize iterative refinement iterations","EPSCISSSetRefinement",i7,&i7,NULL);
    1840:   EPSCISSSetRefinement(eps,i6,i7);

    1842:   EPSCISSGetUseST(eps,&b2);
    1843:   PetscOptionsBool("-eps_ciss_usest","CISS use ST for linear solves","EPSCISSSetUseST",b2,&b2,&flg);
    1844:   if (flg) { EPSCISSSetUseST(eps,b2); }

    1846:   PetscOptionsEnum("-eps_ciss_quadrule","Quadrature rule","EPSCISSSetQuadRule",EPSCISSQuadRules,(PetscEnum)ctx->quad,(PetscEnum*)&quad,&flg);
    1847:   if (flg) { EPSCISSSetQuadRule(eps,quad); }

    1849:   PetscOptionsEnum("-eps_ciss_extraction","Extraction technique","EPSCISSSetExtraction",EPSCISSExtractions,(PetscEnum)ctx->extraction,(PetscEnum*)&extraction,&flg);
    1850:   if (flg) { EPSCISSSetExtraction(eps,extraction); }

    1852:   PetscOptionsTail();
    1853:   return(0);
    1854: }

    1858: PetscErrorCode EPSDestroy_CISS(EPS eps)
    1859: {

    1863:   PetscFree(eps->data);
    1864:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSSetSizes_C",NULL);
    1865:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSGetSizes_C",NULL);
    1866:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSSetThreshold_C",NULL);
    1867:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSGetThreshold_C",NULL);
    1868:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSSetRefinement_C",NULL);
    1869:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSGetRefinement_C",NULL);
    1870:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSSetUseST_C",NULL);
    1871:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSGetUseST_C",NULL);
    1872:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSSetQuadRule_C",NULL);
    1873:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSGetQuadRule_C",NULL);
    1874:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSSetExtraction_C",NULL);
    1875:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSGetExtraction_C",NULL);
    1876:   return(0);
    1877: }

    1881: PetscErrorCode EPSView_CISS(EPS eps,PetscViewer viewer)
    1882: {
    1884:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;
    1885:   PetscBool      isascii;

    1888:   PetscObjectTypeCompare((PetscObject)viewer,PETSCVIEWERASCII,&isascii);
    1889:   if (isascii) {
    1890:     PetscViewerASCIIPrintf(viewer,"  CISS: sizes { integration points: %D, block size: %D, moment size: %D, partitions: %D, maximum block size: %D }\n",ctx->N,ctx->L,ctx->M,ctx->num_subcomm,ctx->L_max);
    1891:     if (ctx->isreal) {
    1892:       PetscViewerASCIIPrintf(viewer,"  CISS: exploiting symmetry of integration points\n");
    1893:     }
    1894:     PetscViewerASCIIPrintf(viewer,"  CISS: threshold { delta: %g, spurious threshold: %g }\n",(double)ctx->delta,(double)ctx->spurious_threshold);
    1895:     PetscViewerASCIIPrintf(viewer,"  CISS: iterative refinement  { inner: %D, blocksize: %D }\n",ctx->refine_inner, ctx->refine_blocksize);
    1896:     if (ctx->usest) {
    1897:       PetscViewerASCIIPrintf(viewer,"  CISS: using ST for linear solves\n");
    1898:     }
    1899:     PetscViewerASCIIPrintf(viewer,"  CISS: extraction: %s\n",EPSCISSExtractions[ctx->extraction]);
    1900:     PetscViewerASCIIPrintf(viewer,"  CISS: quadrature rule: %s\n",EPSCISSQuadRules[ctx->quad]);
    1901:     PetscViewerASCIIPushTab(viewer);
    1902:
    1903:     if (!ctx->usest && ctx->ksp[0]) { KSPView(ctx->ksp[0],viewer); }
    1904:     PetscViewerASCIIPopTab(viewer);
    1905:   }
    1906:   return(0);
    1907: }

    1911: PETSC_EXTERN PetscErrorCode EPSCreate_CISS(EPS eps)
    1912: {
    1914:   EPS_CISS       *ctx = (EPS_CISS*)eps->data;

    1917:   PetscNewLog(eps,&ctx);
    1918:   eps->data = ctx;
    1919:   eps->ops->solve          = EPSSolve_CISS;
    1920:   eps->ops->setup          = EPSSetUp_CISS;
    1921:   eps->ops->setfromoptions = EPSSetFromOptions_CISS;
    1922:   eps->ops->destroy        = EPSDestroy_CISS;
    1923:   eps->ops->reset          = EPSReset_CISS;
    1924:   eps->ops->view           = EPSView_CISS;
    1925:   eps->ops->backtransform  = NULL;
    1926:   eps->ops->computevectors = EPSComputeVectors_Schur;
    1927:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSSetSizes_C",EPSCISSSetSizes_CISS);
    1928:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSGetSizes_C",EPSCISSGetSizes_CISS);
    1929:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSSetThreshold_C",EPSCISSSetThreshold_CISS);
    1930:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSGetThreshold_C",EPSCISSGetThreshold_CISS);
    1931:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSSetRefinement_C",EPSCISSSetRefinement_CISS);
    1932:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSGetRefinement_C",EPSCISSGetRefinement_CISS);
    1933:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSSetUseST_C",EPSCISSSetUseST_CISS);
    1934:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSGetUseST_C",EPSCISSGetUseST_CISS);
    1935:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSSetQuadRule_C",EPSCISSSetQuadRule_CISS);
    1936:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSGetQuadRule_C",EPSCISSGetQuadRule_CISS);
    1937:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSSetExtraction_C",EPSCISSSetExtraction_CISS);
    1938:   PetscObjectComposeFunction((PetscObject)eps,"EPSCISSGetExtraction_C",EPSCISSGetExtraction_CISS);
    1939:   /* set default values of parameters */
    1940:   ctx->N                  = 32;
    1941:   ctx->L                  = 16;
    1942:   ctx->M                  = ctx->N/4;
    1943:   ctx->delta              = 1e-12;
    1944:   ctx->L_max              = 64;
    1945:   ctx->spurious_threshold = 1e-4;
    1946:   ctx->usest              = PETSC_TRUE;
    1947:   ctx->usest_set          = PETSC_FALSE;
    1948:   ctx->isreal             = PETSC_FALSE;
    1949:   ctx->refine_inner       = 0;
    1950:   ctx->refine_blocksize   = 0;
    1951:   ctx->num_subcomm        = 1;
    1952:   ctx->quad               = (EPSCISSQuadRule)0;
    1953:   ctx->extraction         = EPS_CISS_EXTRACTION_RITZ;
    1954:   return(0);
    1955: }