Actual source code: dsnep.c

slepc-3.8.2 2017-12-01
Report Typos and Errors
  1: /*
  2:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3:    SLEPc - Scalable Library for Eigenvalue Problem Computations
  4:    Copyright (c) 2002-2017, Universitat Politecnica de Valencia, Spain

  6:    This file is part of SLEPc.
  7:    SLEPc is distributed under a 2-clause BSD license (see LICENSE).
  8:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  9: */

 11: #include <slepc/private/dsimpl.h>       /*I "slepcds.h" I*/
 12: #include <slepcblaslapack.h>

 14: typedef struct {
 15:   PetscInt nf;                 /* number of functions in f[] */
 16:   FN       f[DS_NUM_EXTRA];    /* functions defining the nonlinear operator */
 17:   PetscInt neig;               /* number of available eigenpairs */
 18: } DS_NEP;

 20: /*
 21:    DSNEPComputeMatrix - Build the matrix associated with a nonlinear operator
 22:    T(lambda) or its derivative T'(lambda), given the parameter lambda, where
 23:    T(lambda) = sum_i E_i*f_i(lambda). The result is written in mat.
 24: */
 25: static PetscErrorCode DSNEPComputeMatrix(DS ds,PetscScalar lambda,PetscBool deriv,DSMatType mat)
 26: {
 28:   DS_NEP         *ctx = (DS_NEP*)ds->data;
 29:   PetscScalar    *T,*E,alpha;
 30:   PetscInt       i,ld,n;
 31:   PetscBLASInt   k,inc=1;

 34:   DSGetDimensions(ds,&n,NULL,NULL,NULL,NULL);
 35:   DSGetLeadingDimension(ds,&ld);
 36:   PetscBLASIntCast(ld*n,&k);
 37:   PetscLogEventBegin(DS_Other,ds,0,0,0);
 38:   DSGetArray(ds,mat,&T);
 39:   PetscMemzero(T,k*sizeof(PetscScalar));
 40:   for (i=0;i<ctx->nf;i++) {
 41:     if (deriv) {
 42:       FNEvaluateDerivative(ctx->f[i],lambda,&alpha);
 43:     } else {
 44:       FNEvaluateFunction(ctx->f[i],lambda,&alpha);
 45:     }
 46:     E = ds->mat[DSMatExtra[i]];
 47:     PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&k,&alpha,E,&inc,T,&inc));
 48:   }
 49:   DSRestoreArray(ds,mat,&T);
 50:   PetscLogEventEnd(DS_Other,ds,0,0,0);
 51:   return(0);
 52: }

 54: PetscErrorCode DSAllocate_NEP(DS ds,PetscInt ld)
 55: {
 57:   DS_NEP         *ctx = (DS_NEP*)ds->data;
 58:   PetscInt       i;

 61:   if (!ctx->nf) SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_WRONGSTATE,"DSNEP requires passing some functions via DSSetFN()");
 62:   DSAllocateMat_Private(ds,DS_MAT_X);
 63:   for (i=0;i<ctx->nf;i++) {
 64:     DSAllocateMat_Private(ds,DSMatExtra[i]);
 65:   }
 66:   PetscFree(ds->perm);
 67:   PetscMalloc1(ld,&ds->perm);
 68:   PetscLogObjectMemory((PetscObject)ds,ld*sizeof(PetscInt));
 69:   return(0);
 70: }

 72: PetscErrorCode DSView_NEP(DS ds,PetscViewer viewer)
 73: {
 74:   PetscErrorCode    ierr;
 75:   DS_NEP            *ctx = (DS_NEP*)ds->data;
 76:   PetscViewerFormat format;
 77:   PetscInt          i;

 80:   PetscViewerGetFormat(viewer,&format);
 81:   PetscViewerASCIIPrintf(viewer,"number of functions: %D\n",ctx->nf);
 82:   if (format == PETSC_VIEWER_ASCII_INFO || format == PETSC_VIEWER_ASCII_INFO_DETAIL) return(0);
 83:   for (i=0;i<ctx->nf;i++) {
 84:     FNView(ctx->f[i],viewer);
 85:     DSViewMat(ds,viewer,DSMatExtra[i]);
 86:   }
 87:   if (ds->state>DS_STATE_INTERMEDIATE) {
 88:     DSViewMat(ds,viewer,DS_MAT_X);
 89:   }
 90:   return(0);
 91: }

 93: PetscErrorCode DSVectors_NEP(DS ds,DSMatType mat,PetscInt *j,PetscReal *rnorm)
 94: {
 96:   if (rnorm) SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_SUP,"Not implemented yet");
 97:   switch (mat) {
 98:     case DS_MAT_X:
 99:       break;
100:     case DS_MAT_Y:
101:       SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_SUP,"Not implemented yet");
102:       break;
103:     default:
104:       SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid mat parameter");
105:   }
106:   return(0);
107: }

109: PetscErrorCode DSSort_NEP(DS ds,PetscScalar *wr,PetscScalar *wi,PetscScalar *rr,PetscScalar *ri,PetscInt *dummy)
110: {
112:   DS_NEP         *ctx = (DS_NEP*)ds->data;
113:   PetscInt       n,l,i,j,k,p,*perm,told,ld=ds->ld;
114:   PetscScalar    *A,*X,rtmp;

117:   if (!ds->sc) return(0);
118:   n = ds->n;
119:   l = ds->l;
120:   A  = ds->mat[DS_MAT_A];
121:   perm = ds->perm;
122:   for (i=0;i<ctx->neig;i++) perm[i] = i;
123:   told = ds->t;
124:   ds->t = ctx->neig;  /* force the sorting routines to consider ctx->neig eigenvalues */
125:   if (rr) {
126:     DSSortEigenvalues_Private(ds,rr,ri,perm,PETSC_FALSE);
127:   } else {
128:     DSSortEigenvalues_Private(ds,wr,NULL,perm,PETSC_FALSE);
129:   }
130:   ds->t = told;  /* restore value of t */
131:   for (i=l;i<n;i++) A[i+i*ld] = wr[perm[i]];
132:   for (i=l;i<n;i++) wr[i] = A[i+i*ld];
133:   /* cannot use DSPermuteColumns_Private() since not all columns are filled */
134:   X  = ds->mat[DS_MAT_X];
135:   for (i=0;i<ctx->neig;i++) {
136:     p = perm[i];
137:     if (p != i) {
138:       j = i + 1;
139:       while (perm[j] != i) j++;
140:       perm[j] = p; perm[i] = i;
141:       /* swap columns i and j */
142:       for (k=0;k<n;k++) {
143:         rtmp  = X[k+p*ld]; X[k+p*ld] = X[k+i*ld]; X[k+i*ld] = rtmp;
144:       }
145:     }
146:   }
147:   return(0);
148: }

150: PetscErrorCode DSSolve_NEP_SLP(DS ds,PetscScalar *wr,PetscScalar *wi)
151: {
152: #if defined(SLEPC_MISSING_LAPACK_GGEV)
154:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GGEV - Lapack routine is unavailable");
155: #else
157:   DS_NEP         *ctx = (DS_NEP*)ds->data;
158:   PetscScalar    *A,*B,*W,*X,*work,*alpha,*beta;
159:   PetscScalar    norm,sigma,lambda,mu,re,re2;
160:   PetscBLASInt   info,n,ld,lrwork=0,lwork,one=1;
161:   PetscInt       it,pos,j,maxit=100,result;
162:   PetscReal      tol;
163: #if defined(PETSC_USE_COMPLEX)
164:   PetscReal      *rwork;
165: #else
166:   PetscReal      *alphai,im,im2;
167: #endif

170:   if (!ds->mat[DS_MAT_A]) {
171:     DSAllocateMat_Private(ds,DS_MAT_A);
172:   }
173:   if (!ds->mat[DS_MAT_B]) {
174:     DSAllocateMat_Private(ds,DS_MAT_B);
175:   }
176:   if (!ds->mat[DS_MAT_W]) {
177:     DSAllocateMat_Private(ds,DS_MAT_W);
178:   }
179:   PetscBLASIntCast(ds->n,&n);
180:   PetscBLASIntCast(ds->ld,&ld);
181: #if defined(PETSC_USE_COMPLEX)
182:   PetscBLASIntCast(2*ds->n+2*ds->n,&lwork);
183:   PetscBLASIntCast(8*ds->n,&lrwork);
184: #else
185:   PetscBLASIntCast(3*ds->n+8*ds->n,&lwork);
186: #endif
187:   DSAllocateWork_Private(ds,lwork,lrwork,0);
188:   alpha = ds->work;
189:   beta = ds->work + ds->n;
190: #if defined(PETSC_USE_COMPLEX)
191:   work = ds->work + 2*ds->n;
192:   lwork -= 2*ds->n;
193: #else
194:   alphai = ds->work + 2*ds->n;
195:   work = ds->work + 3*ds->n;
196:   lwork -= 3*ds->n;
197: #endif
198:   A = ds->mat[DS_MAT_A];
199:   B = ds->mat[DS_MAT_B];
200:   W = ds->mat[DS_MAT_W];
201:   X = ds->mat[DS_MAT_X];

203:   sigma = 0.0;
204:   lambda = sigma;
205:   tol = 1000*n*PETSC_MACHINE_EPSILON;

207:   for (it=0;it<maxit;it++) {

209:     /* evaluate T and T' */
210:     DSNEPComputeMatrix(ds,lambda,PETSC_FALSE,DS_MAT_A);
211:     DSNEPComputeMatrix(ds,lambda,PETSC_TRUE,DS_MAT_B);

213:     /* compute eigenvalue correction mu and eigenvector u */
214: #if defined(PETSC_USE_COMPLEX)
215:     rwork = ds->rwork;
216:     PetscStackCallBLAS("LAPACKggev",LAPACKggev_("N","V",&n,A,&ld,B,&ld,alpha,beta,NULL,&ld,W,&ld,work,&lwork,rwork,&info));
217: #else
218:     PetscStackCallBLAS("LAPACKggev",LAPACKggev_("N","V",&n,A,&ld,B,&ld,alpha,alphai,beta,NULL,&ld,W,&ld,work,&lwork,&info));
219: #endif
220:     SlepcCheckLapackInfo("ggev",info);

222:     /* find smallest eigenvalue */
223:     j = 0;
224:     if (beta[j]==0.0) re = (PetscRealPart(alpha[j])>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
225:     else re = alpha[j]/beta[j];
226: #if !defined(PETSC_USE_COMPLEX)
227:     if (beta[j]==0.0) im = (alphai[j]>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
228:     else im = alphai[j]/beta[j];
229: #endif
230:     pos = 0;
231:     for (j=1;j<n;j++) {
232:       if (beta[j]==0.0) re2 = (PetscRealPart(alpha[j])>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
233:       else re2 = alpha[j]/beta[j];
234: #if !defined(PETSC_USE_COMPLEX)
235:       if (beta[j]==0.0) im2 = (alphai[j]>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
236:       else im2 = alphai[j]/beta[j];
237:       SlepcCompareSmallestMagnitude(re,im,re2,im2,&result,NULL);
238: #else
239:       SlepcCompareSmallestMagnitude(re,0.0,re2,0.0,&result,NULL);
240: #endif
241:       if (result > 0) {
242:         re = re2;
243: #if !defined(PETSC_USE_COMPLEX)
244:         im = im2;
245: #endif
246:         pos = j;
247:       }
248:     }

250: #if !defined(PETSC_USE_COMPLEX)
251:     if (im!=0.0) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"DSNEP found a complex eigenvalue; try rerunning with complex scalars");
252: #endif
253:     mu = alpha[pos];
254:     PetscMemcpy(X,W+pos*ld,n*sizeof(PetscScalar));
255:     norm = BLASnrm2_(&n,X,&one);
256:     norm = 1.0/norm;
257:     PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,X,&one));

259:     /* correct eigenvalue approximation */
260:     lambda = lambda - mu;
261:     if (PetscAbsScalar(mu)<=tol) break;
262:   }

264:   if (it==maxit) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_CONV_FAILED,"DSNEP did not converge");
265:   ctx->neig = 1;
266:   wr[0] = lambda;
267:   if (wi) wi[0] = 0.0;
268:   return(0);
269: #endif
270: }

272: PetscErrorCode DSSynchronize_NEP(DS ds,PetscScalar eigr[],PetscScalar eigi[])
273: {
275:   PetscInt       k=0;
276:   PetscMPIInt    n,rank,size,off=0;

279:   if (ds->state>=DS_STATE_CONDENSED) k += ds->n;
280:   if (eigr) k += 1;
281:   if (eigi) k += 1;
282:   DSAllocateWork_Private(ds,k,0,0);
283:   PetscMPIIntCast(k*sizeof(PetscScalar),&size);
284:   PetscMPIIntCast(ds->n,&n);
285:   MPI_Comm_rank(PetscObjectComm((PetscObject)ds),&rank);
286:   if (!rank) {
287:     if (ds->state>=DS_STATE_CONDENSED) {
288:       MPI_Pack(ds->mat[DS_MAT_X],n,MPIU_SCALAR,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
289:     }
290:     if (eigr) {
291:       MPI_Pack(eigr,1,MPIU_SCALAR,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
292:     }
293:     if (eigi) {
294:       MPI_Pack(eigi,1,MPIU_SCALAR,ds->work,size,&off,PetscObjectComm((PetscObject)ds));
295:     }
296:   }
297:   MPI_Bcast(ds->work,size,MPI_BYTE,0,PetscObjectComm((PetscObject)ds));
298:   if (rank) {
299:     if (ds->state>=DS_STATE_CONDENSED) {
300:       MPI_Unpack(ds->work,size,&off,ds->mat[DS_MAT_X],n,MPIU_SCALAR,PetscObjectComm((PetscObject)ds));
301:     }
302:     if (eigr) {
303:       MPI_Unpack(ds->work,size,&off,eigr,1,MPIU_SCALAR,PetscObjectComm((PetscObject)ds));
304:     }
305:     if (eigi) {
306:       MPI_Unpack(ds->work,size,&off,eigi,1,MPIU_SCALAR,PetscObjectComm((PetscObject)ds));
307:     }
308:   }
309:   return(0);
310: }

312: static PetscErrorCode DSNEPSetFN_NEP(DS ds,PetscInt n,FN fn[])
313: {
315:   DS_NEP         *ctx = (DS_NEP*)ds->data;
316:   PetscInt       i;

319:   if (n<=0) SETERRQ1(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Must have one or more functions, you have %D",n);
320:   if (n>DS_NUM_EXTRA) SETERRQ2(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Too many functions, you specified %D but the limit is %D",n,DS_NUM_EXTRA);
321:   if (ds->ld) { PetscInfo(ds,"DSNEPSetFN() called after DSAllocate()\n"); }
322:   for (i=0;i<ctx->nf;i++) {
323:     FNDestroy(&ctx->f[i]);
324:   }
325:   for (i=0;i<n;i++) {
326:     PetscObjectReference((PetscObject)fn[i]);
327:     ctx->f[i] = fn[i];
328:   }
329:   ctx->nf = n;
330:   return(0);
331: }

333: /*@
334:    DSNEPSetFN - Sets a number of functions that define the nonlinear
335:    eigenproblem.

337:    Collective on DS and FN

339:    Input Parameters:
340: +  ds - the direct solver context
341: .  n  - number of functions
342: -  fn - array of functions

344:    Notes:
345:    The nonlinear eigenproblem is defined in terms of the split nonlinear
346:    operator T(lambda) = sum_i A_i*f_i(lambda).

348:    This function must be called before DSAllocate(). Then DSAllocate()
349:    will allocate an extra matrix A_i per each function, that can be
350:    filled in the usual way.

352:    Level: advanced

354: .seealso: DSNEPGetFN(), DSAllocate()
355:  @*/
356: PetscErrorCode DSNEPSetFN(DS ds,PetscInt n,FN fn[])
357: {
358:   PetscInt       i;

365:   for (i=0;i<n;i++) {
368:   }
369:   PetscTryMethod(ds,"DSNEPSetFN_C",(DS,PetscInt,FN[]),(ds,n,fn));
370:   return(0);
371: }

373: static PetscErrorCode DSNEPGetFN_NEP(DS ds,PetscInt k,FN *fn)
374: {
375:   DS_NEP *ctx = (DS_NEP*)ds->data;

378:   if (k<0 || k>=ctx->nf) SETERRQ1(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"k must be between 0 and %D",ctx->nf-1);
379:   *fn = ctx->f[k];
380:   return(0);
381: }

383: /*@
384:    DSNEPGetFN - Gets the functions associated with the nonlinear DS.

386:    Not collective, though parallel FNs are returned if the DS is parallel

388:    Input Parameter:
389: +  ds - the direct solver context
390: -  k  - the index of the requested function (starting in 0)

392:    Output Parameter:
393: .  fn - the function

395:    Level: advanced

397: .seealso: DSNEPSetFN()
398: @*/
399: PetscErrorCode DSNEPGetFN(DS ds,PetscInt k,FN *fn)
400: {

406:   PetscUseMethod(ds,"DSNEPGetFN_C",(DS,PetscInt,FN*),(ds,k,fn));
407:   return(0);
408: }

410: static PetscErrorCode DSNEPGetNumFN_NEP(DS ds,PetscInt *n)
411: {
412:   DS_NEP *ctx = (DS_NEP*)ds->data;

415:   *n = ctx->nf;
416:   return(0);
417: }

419: /*@
420:    DSNEPGetNumFN - Returns the number of functions stored internally by
421:    the DS.

423:    Not collective

425:    Input Parameter:
426: .  ds - the direct solver context

428:    Output Parameters:
429: .  n - the number of functions passed in DSNEPSetFN()

431:    Level: advanced

433: .seealso: DSNEPSetFN()
434: @*/
435: PetscErrorCode DSNEPGetNumFN(DS ds,PetscInt *n)
436: {

442:   PetscUseMethod(ds,"DSNEPGetNumFN_C",(DS,PetscInt*),(ds,n));
443:   return(0);
444: }

446: PetscErrorCode DSDestroy_NEP(DS ds)
447: {
449:   DS_NEP         *ctx = (DS_NEP*)ds->data;
450:   PetscInt       i;

453:   for (i=0;i<ctx->nf;i++) {
454:     FNDestroy(&ctx->f[i]);
455:   }
456:   PetscFree(ds->data);
457:   PetscObjectComposeFunction((PetscObject)ds,"DSNEPSetFN_C",NULL);
458:   PetscObjectComposeFunction((PetscObject)ds,"DSNEPGetFN_C",NULL);
459:   PetscObjectComposeFunction((PetscObject)ds,"DSNEPGetNumFN_C",NULL);
460:   return(0);
461: }

463: PETSC_EXTERN PetscErrorCode DSCreate_NEP(DS ds)
464: {
465:   DS_NEP         *ctx;

469:   PetscNewLog(ds,&ctx);
470:   ds->data = (void*)ctx;

472:   ds->ops->allocate      = DSAllocate_NEP;
473:   ds->ops->view          = DSView_NEP;
474:   ds->ops->vectors       = DSVectors_NEP;
475:   ds->ops->solve[0]      = DSSolve_NEP_SLP;
476:   ds->ops->sort          = DSSort_NEP;
477:   ds->ops->synchronize   = DSSynchronize_NEP;
478:   ds->ops->destroy       = DSDestroy_NEP;
479:   PetscObjectComposeFunction((PetscObject)ds,"DSNEPSetFN_C",DSNEPSetFN_NEP);
480:   PetscObjectComposeFunction((PetscObject)ds,"DSNEPGetFN_C",DSNEPGetFN_NEP);
481:   PetscObjectComposeFunction((PetscObject)ds,"DSNEPGetNumFN_C",DSNEPGetNumFN_NEP);
482:   return(0);
483: }