Actual source code: dsnep.c
slepc-3.7.4 2017-05-17
1: /*
2: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3: SLEPc - Scalable Library for Eigenvalue Problem Computations
4: Copyright (c) 2002-2016, Universitat Politecnica de Valencia, Spain
6: This file is part of SLEPc.
8: SLEPc is free software: you can redistribute it and/or modify it under the
9: terms of version 3 of the GNU Lesser General Public License as published by
10: the Free Software Foundation.
12: SLEPc is distributed in the hope that it will be useful, but WITHOUT ANY
13: WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
14: FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for
15: more details.
17: You should have received a copy of the GNU Lesser General Public License
18: along with SLEPc. If not, see <http://www.gnu.org/licenses/>.
19: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
20: */
22: #include <slepc/private/dsimpl.h> /*I "slepcds.h" I*/
23: #include <slepcblaslapack.h>
25: typedef struct {
26: PetscInt nf; /* number of functions in f[] */
27: FN f[DS_NUM_EXTRA]; /* functions defining the nonlinear operator */
28: } DS_NEP;
32: /*
33: DSNEPComputeMatrix - Build the matrix associated with a nonlinear operator
34: T(lambda) or its derivative T'(lambda), given the parameter lambda, where
35: T(lambda) = sum_i E_i*f_i(lambda). The result is written in mat.
36: */
37: static PetscErrorCode DSNEPComputeMatrix(DS ds,PetscScalar lambda,PetscBool deriv,DSMatType mat)
38: {
40: DS_NEP *ctx = (DS_NEP*)ds->data;
41: PetscScalar *T,*E,alpha;
42: PetscInt i,ld,n;
43: PetscBLASInt k,inc=1;
46: DSGetDimensions(ds,&n,NULL,NULL,NULL,NULL);
47: DSGetLeadingDimension(ds,&ld);
48: PetscBLASIntCast(ld*n,&k);
49: PetscLogEventBegin(DS_Other,ds,0,0,0);
50: DSGetArray(ds,mat,&T);
51: PetscMemzero(T,k*sizeof(PetscScalar));
52: for (i=0;i<ctx->nf;i++) {
53: if (deriv) {
54: FNEvaluateDerivative(ctx->f[i],lambda,&alpha);
55: } else {
56: FNEvaluateFunction(ctx->f[i],lambda,&alpha);
57: }
58: E = ds->mat[DSMatExtra[i]];
59: PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&k,&alpha,E,&inc,T,&inc));
60: }
61: DSRestoreArray(ds,mat,&T);
62: PetscLogEventEnd(DS_Other,ds,0,0,0);
63: return(0);
64: }
68: PetscErrorCode DSAllocate_NEP(DS ds,PetscInt ld)
69: {
71: DS_NEP *ctx = (DS_NEP*)ds->data;
72: PetscInt i;
75: if (!ctx->nf) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_WRONGSTATE,"DSNEP requires passing some functions via DSSetFN()");
76: DSAllocateMat_Private(ds,DS_MAT_X);
77: for (i=0;i<ctx->nf;i++) {
78: DSAllocateMat_Private(ds,DSMatExtra[i]);
79: }
80: PetscFree(ds->perm);
81: PetscMalloc1(ld,&ds->perm);
82: PetscLogObjectMemory((PetscObject)ds,ld*sizeof(PetscInt));
83: return(0);
84: }
88: PetscErrorCode DSView_NEP(DS ds,PetscViewer viewer)
89: {
90: PetscErrorCode ierr;
91: DS_NEP *ctx = (DS_NEP*)ds->data;
92: PetscViewerFormat format;
93: PetscInt i;
96: PetscViewerGetFormat(viewer,&format);
97: PetscViewerASCIIPrintf(viewer," number of functions: %D\n",ctx->nf);
98: if (format == PETSC_VIEWER_ASCII_INFO || format == PETSC_VIEWER_ASCII_INFO_DETAIL) return(0);
99: for (i=0;i<ctx->nf;i++) {
100: FNView(ctx->f[i],viewer);
101: DSViewMat(ds,viewer,DSMatExtra[i]);
102: }
103: if (ds->state>DS_STATE_INTERMEDIATE) {
104: DSViewMat(ds,viewer,DS_MAT_X);
105: }
106: return(0);
107: }
111: PetscErrorCode DSVectors_NEP(DS ds,DSMatType mat,PetscInt *j,PetscReal *rnorm)
112: {
114: if (rnorm) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Not implemented yet");
115: switch (mat) {
116: case DS_MAT_X:
117: break;
118: case DS_MAT_Y:
119: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Not implemented yet");
120: break;
121: default:
122: SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid mat parameter");
123: }
124: return(0);
125: }
129: PetscErrorCode DSNormalize_NEP(DS ds,DSMatType mat,PetscInt col)
130: {
132: PetscInt i,i0,i1;
133: PetscBLASInt ld,n,one = 1;
134: PetscScalar norm,*x;
137: switch (mat) {
138: case DS_MAT_X:
139: break;
140: case DS_MAT_Y:
141: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Not implemented yet");
142: break;
143: default:
144: SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid mat parameter");
145: }
146: PetscBLASIntCast(ds->n,&n);
147: PetscBLASIntCast(ds->ld,&ld);
148: DSGetArray(ds,mat,&x);
149: if (col < 0) {
150: i0 = 0; i1 = ds->n;
151: } else {
152: i0 = col; i1 = col+1;
153: }
154: for (i=i0;i<i1;i++) {
155: norm = BLASnrm2_(&n,&x[ld*i],&one);
156: norm = 1.0/norm;
157: PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*i],&one));
158: }
159: return(0);
160: }
164: PetscErrorCode DSSort_NEP(DS ds,PetscScalar *wr,PetscScalar *wi,PetscScalar *rr,PetscScalar *ri,PetscInt *k)
165: {
167: PetscInt n,l,i,*perm,ld=ds->ld;
168: PetscScalar *A;
171: if (!ds->sc) return(0);
172: n = ds->n;
173: l = ds->l;
174: A = ds->mat[DS_MAT_A];
175: perm = ds->perm;
176: for (i=l;i<n;i++) wr[i] = A[i+i*ld];
177: if (rr) {
178: DSSortEigenvalues_Private(ds,rr,ri,perm,PETSC_FALSE);
179: } else {
180: DSSortEigenvalues_Private(ds,wr,NULL,perm,PETSC_FALSE);
181: }
182: for (i=l;i<n;i++) A[i+i*ld] = wr[perm[i]];
183: for (i=l;i<n;i++) wr[i] = A[i+i*ld];
184: DSPermuteColumns_Private(ds,l,n,DS_MAT_Q,perm);
185: return(0);
186: }
190: PetscErrorCode DSSolve_NEP_SLP(DS ds,PetscScalar *wr,PetscScalar *wi)
191: {
192: #if defined(SLEPC_MISSING_LAPACK_GGEV)
194: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GGEV - Lapack routine is unavailable");
195: #else
197: PetscScalar *A,*B,*W,*X,*work,*alpha,*beta;
198: PetscScalar norm,sigma,lambda,mu,re,re2;
199: PetscBLASInt info,n,ld,lrwork=0,lwork,one=1;
200: PetscInt it,pos,j,maxit=100,result;
201: PetscReal tol;
202: #if defined(PETSC_USE_COMPLEX)
203: PetscReal *rwork;
204: #else
205: PetscReal *alphai,im,im2;
206: #endif
209: if (!ds->mat[DS_MAT_A]) {
210: DSAllocateMat_Private(ds,DS_MAT_A);
211: }
212: if (!ds->mat[DS_MAT_B]) {
213: DSAllocateMat_Private(ds,DS_MAT_B);
214: }
215: if (!ds->mat[DS_MAT_W]) {
216: DSAllocateMat_Private(ds,DS_MAT_W);
217: }
218: PetscBLASIntCast(ds->n,&n);
219: PetscBLASIntCast(ds->ld,&ld);
220: #if defined(PETSC_USE_COMPLEX)
221: PetscBLASIntCast(2*ds->n+2*ds->n,&lwork);
222: PetscBLASIntCast(8*ds->n,&lrwork);
223: #else
224: PetscBLASIntCast(3*ds->n+8*ds->n,&lwork);
225: #endif
226: DSAllocateWork_Private(ds,lwork,lrwork,0);
227: alpha = ds->work;
228: beta = ds->work + ds->n;
229: #if defined(PETSC_USE_COMPLEX)
230: work = ds->work + 2*ds->n;
231: lwork -= 2*ds->n;
232: #else
233: alphai = ds->work + 2*ds->n;
234: work = ds->work + 3*ds->n;
235: lwork -= 3*ds->n;
236: #endif
237: A = ds->mat[DS_MAT_A];
238: B = ds->mat[DS_MAT_B];
239: W = ds->mat[DS_MAT_W];
240: X = ds->mat[DS_MAT_X];
242: sigma = 0.0;
243: lambda = sigma;
244: tol = 1000*n*PETSC_MACHINE_EPSILON;
246: for (it=0;it<maxit;it++) {
248: /* evaluate T and T' */
249: DSNEPComputeMatrix(ds,lambda,PETSC_FALSE,DS_MAT_A);
250: DSNEPComputeMatrix(ds,lambda,PETSC_TRUE,DS_MAT_B);
252: /* compute eigenvalue correction mu and eigenvector u */
253: #if defined(PETSC_USE_COMPLEX)
254: rwork = ds->rwork;
255: PetscStackCallBLAS("LAPACKggev",LAPACKggev_("N","V",&n,A,&ld,B,&ld,alpha,beta,NULL,&ld,W,&ld,work,&lwork,rwork,&info));
256: if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack ZGGEV %d",info);
257: #else
258: PetscStackCallBLAS("LAPACKggev",LAPACKggev_("N","V",&n,A,&ld,B,&ld,alpha,alphai,beta,NULL,&ld,W,&ld,work,&lwork,&info));
259: if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack DGGEV %d",info);
260: #endif
262: /* find smallest eigenvalue */
263: j = 0;
264: if (beta[j]==0.0) re = (PetscRealPart(alpha[j])>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
265: else re = alpha[j]/beta[j];
266: #if !defined(PETSC_USE_COMPLEX)
267: if (beta[j]==0.0) im = (alphai[j]>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
268: else im = alphai[j]/beta[j];
269: #endif
270: pos = 0;
271: for (j=1;j<n;j++) {
272: if (beta[j]==0.0) re2 = (PetscRealPart(alpha[j])>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
273: else re2 = alpha[j]/beta[j];
274: #if !defined(PETSC_USE_COMPLEX)
275: if (beta[j]==0.0) im2 = (alphai[j]>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
276: else im2 = alphai[j]/beta[j];
277: SlepcCompareSmallestMagnitude(re,im,re2,im2,&result,NULL);
278: #else
279: SlepcCompareSmallestMagnitude(re,0.0,re2,0.0,&result,NULL);
280: #endif
281: if (result > 0) {
282: re = re2;
283: #if !defined(PETSC_USE_COMPLEX)
284: im = im2;
285: #endif
286: pos = j;
287: }
288: }
290: #if !defined(PETSC_USE_COMPLEX)
291: if (im!=0.0) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"DSNEP found a complex eigenvalue; try rerunning with complex scalars");
292: #endif
293: mu = alpha[pos];
294: PetscMemcpy(X,W+pos*ld,n*sizeof(PetscScalar));
295: norm = BLASnrm2_(&n,X,&one);
296: norm = 1.0/norm;
297: PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,X,&one));
299: /* correct eigenvalue approximation */
300: lambda = lambda - mu;
301: if (PetscAbsScalar(mu)<=tol) break;
302: }
304: wr[0] = lambda;
305: if (wi) wi[0] = 0.0;
307: if (it==maxit) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_CONV_FAILED,"DSNEP did not converge");
308: return(0);
309: #endif
310: }
314: static PetscErrorCode DSNEPSetFN_NEP(DS ds,PetscInt n,FN fn[])
315: {
317: DS_NEP *ctx = (DS_NEP*)ds->data;
318: PetscInt i;
321: if (n<=0) SETERRQ1(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Must have one or more functions, you have %D",n);
322: 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);
323: if (ds->ld) { PetscInfo(ds,"DSNEPSetFN() called after DSAllocate()\n"); }
324: for (i=0;i<ctx->nf;i++) {
325: FNDestroy(&ctx->f[i]);
326: }
327: for (i=0;i<n;i++) {
328: PetscObjectReference((PetscObject)fn[i]);
329: ctx->f[i] = fn[i];
330: }
331: ctx->nf = n;
332: return(0);
333: }
337: /*@
338: DSNEPSetFN - Sets a number of functions that define the nonlinear
339: eigenproblem.
341: Collective on DS and FN
343: Input Parameters:
344: + ds - the direct solver context
345: . n - number of functions
346: - fn - array of functions
348: Notes:
349: The nonlinear eigenproblem is defined in terms of the split nonlinear
350: operator T(lambda) = sum_i A_i*f_i(lambda).
352: This function must be called before DSAllocate(). Then DSAllocate()
353: will allocate an extra matrix A_i per each function, that can be
354: filled in the usual way.
356: Level: advanced
358: .seealso: DSNEPGetFN(), DSAllocate()
359: @*/
360: PetscErrorCode DSNEPSetFN(DS ds,PetscInt n,FN fn[])
361: {
362: PetscInt i;
369: for (i=0;i<n;i++) {
372: }
373: PetscTryMethod(ds,"DSNEPSetFN_C",(DS,PetscInt,FN[]),(ds,n,fn));
374: return(0);
375: }
379: static PetscErrorCode DSNEPGetFN_NEP(DS ds,PetscInt k,FN *fn)
380: {
381: DS_NEP *ctx = (DS_NEP*)ds->data;
384: if (k<0 || k>=ctx->nf) SETERRQ1(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"k must be between 0 and %D",ctx->nf-1);
385: *fn = ctx->f[k];
386: return(0);
387: }
391: /*@
392: DSNEPGetFN - Gets the functions associated with the nonlinear DS.
394: Not collective, though parallel FNs are returned if the DS is parallel
396: Input Parameter:
397: + ds - the direct solver context
398: - k - the index of the requested function (starting in 0)
400: Output Parameter:
401: . fn - the function
403: Level: advanced
405: .seealso: DSNEPSetFN()
406: @*/
407: PetscErrorCode DSNEPGetFN(DS ds,PetscInt k,FN *fn)
408: {
414: PetscUseMethod(ds,"DSNEPGetFN_C",(DS,PetscInt,FN*),(ds,k,fn));
415: return(0);
416: }
420: static PetscErrorCode DSNEPGetNumFN_NEP(DS ds,PetscInt *n)
421: {
422: DS_NEP *ctx = (DS_NEP*)ds->data;
425: *n = ctx->nf;
426: return(0);
427: }
431: /*@
432: DSNEPGetNumFN - Returns the number of functions stored internally by
433: the DS.
435: Not collective
437: Input Parameter:
438: . ds - the direct solver context
440: Output Parameters:
441: . n - the number of functions passed in DSNEPSetFN()
443: Level: advanced
445: .seealso: DSNEPSetFN()
446: @*/
447: PetscErrorCode DSNEPGetNumFN(DS ds,PetscInt *n)
448: {
454: PetscUseMethod(ds,"DSNEPGetNumFN_C",(DS,PetscInt*),(ds,n));
455: return(0);
456: }
460: PetscErrorCode DSDestroy_NEP(DS ds)
461: {
463: DS_NEP *ctx = (DS_NEP*)ds->data;
464: PetscInt i;
467: for (i=0;i<ctx->nf;i++) {
468: FNDestroy(&ctx->f[i]);
469: }
470: PetscFree(ds->data);
471: PetscObjectComposeFunction((PetscObject)ds,"DSNEPSetFN_C",NULL);
472: PetscObjectComposeFunction((PetscObject)ds,"DSNEPGetFN_C",NULL);
473: PetscObjectComposeFunction((PetscObject)ds,"DSNEPGetNumFN_C",NULL);
474: return(0);
475: }
479: PETSC_EXTERN PetscErrorCode DSCreate_NEP(DS ds)
480: {
481: DS_NEP *ctx;
485: PetscNewLog(ds,&ctx);
486: ds->data = (void*)ctx;
488: ds->ops->allocate = DSAllocate_NEP;
489: ds->ops->view = DSView_NEP;
490: ds->ops->vectors = DSVectors_NEP;
491: ds->ops->solve[0] = DSSolve_NEP_SLP;
492: ds->ops->sort = DSSort_NEP;
493: ds->ops->normalize = DSNormalize_NEP;
494: ds->ops->destroy = DSDestroy_NEP;
495: PetscObjectComposeFunction((PetscObject)ds,"DSNEPSetFN_C",DSNEPSetFN_NEP);
496: PetscObjectComposeFunction((PetscObject)ds,"DSNEPGetFN_C",DSNEPGetFN_NEP);
497: PetscObjectComposeFunction((PetscObject)ds,"DSNEPGetNumFN_C",DSNEPGetNumFN_NEP);
498: return(0);
499: }