Actual source code: dsnep.c
slepc-3.8.2 2017-12-01
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: }