1: /*
2: Basic routines
4: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5: SLEPc - Scalable Library for Eigenvalue Problem Computations
6: Copyright (c) 2002-2015, Universitat Politecnica de Valencia, Spain
8: This file is part of SLEPc.
10: SLEPc is free software: you can redistribute it and/or modify it under the
11: terms of version 3 of the GNU Lesser General Public License as published by
12: the Free Software Foundation.
14: SLEPc is distributed in the hope that it will be useful, but WITHOUT ANY
15: WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
16: FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for
17: more details.
19: You should have received a copy of the GNU Lesser General Public License
20: along with SLEPc. If not, see <http://www.gnu.org/licenses/>.
21: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
22: */
24: #include <slepc/private/fnimpl.h> /*I "slepcfn.h" I*/
25: #include <slepcblaslapack.h>
27: PetscFunctionList FNList = 0;
28: PetscBool FNRegisterAllCalled = PETSC_FALSE;
29: PetscClassId FN_CLASSID = 0;
30: PetscLogEvent FN_Evaluate = 0;
31: static PetscBool FNPackageInitialized = PETSC_FALSE;
35: /*@C
36: FNFinalizePackage - This function destroys everything in the Slepc interface
37: to the FN package. It is called from SlepcFinalize().
39: Level: developer
41: .seealso: SlepcFinalize()
42: @*/
43: PetscErrorCode FNFinalizePackage(void) 44: {
48: PetscFunctionListDestroy(&FNList);
49: FNPackageInitialized = PETSC_FALSE;
50: FNRegisterAllCalled = PETSC_FALSE;
51: return(0);
52: }
56: /*@C
57: FNInitializePackage - This function initializes everything in the FN package.
58: It is called from PetscDLLibraryRegister() when using dynamic libraries, and
59: on the first call to FNCreate() when using static libraries.
61: Level: developer
63: .seealso: SlepcInitialize()
64: @*/
65: PetscErrorCode FNInitializePackage(void) 66: {
67: char logList[256];
68: char *className;
69: PetscBool opt;
70: PetscErrorCode ierr;
73: if (FNPackageInitialized) return(0);
74: FNPackageInitialized = PETSC_TRUE;
75: /* Register Classes */
76: PetscClassIdRegister("Math Function",&FN_CLASSID);
77: /* Register Constructors */
78: FNRegisterAll();
79: /* Register Events */
80: PetscLogEventRegister("FNEvaluate",FN_CLASSID,&FN_Evaluate);
81: /* Process info exclusions */
82: PetscOptionsGetString(NULL,"-info_exclude",logList,256,&opt);
83: if (opt) {
84: PetscStrstr(logList,"fn",&className);
85: if (className) {
86: PetscInfoDeactivateClass(FN_CLASSID);
87: }
88: }
89: /* Process summary exclusions */
90: PetscOptionsGetString(NULL,"-log_summary_exclude",logList,256,&opt);
91: if (opt) {
92: PetscStrstr(logList,"fn",&className);
93: if (className) {
94: PetscLogEventDeactivateClass(FN_CLASSID);
95: }
96: }
97: PetscRegisterFinalize(FNFinalizePackage);
98: return(0);
99: }
103: /*@
104: FNCreate - Creates an FN context.
106: Collective on MPI_Comm
108: Input Parameter:
109: . comm - MPI communicator
111: Output Parameter:
112: . newfn - location to put the FN context
114: Level: beginner
116: .seealso: FNDestroy(), FN117: @*/
118: PetscErrorCode FNCreate(MPI_Comm comm,FN *newfn)119: {
120: FN fn;
125: *newfn = 0;
126: FNInitializePackage();
127: SlepcHeaderCreate(fn,FN_CLASSID,"FN","Math Function","FN",comm,FNDestroy,FNView);
129: fn->alpha = 1.0;
130: fn->beta = 1.0;
132: fn->W = NULL;
133: fn->data = NULL;
135: *newfn = fn;
136: return(0);
137: }
141: /*@C
142: FNSetOptionsPrefix - Sets the prefix used for searching for all
143: FN options in the database.
145: Logically Collective on FN147: Input Parameters:
148: + fn - the math function context
149: - prefix - the prefix string to prepend to all FN option requests
151: Notes:
152: A hyphen (-) must NOT be given at the beginning of the prefix name.
153: The first character of all runtime options is AUTOMATICALLY the
154: hyphen.
156: Level: advanced
158: .seealso: FNAppendOptionsPrefix()
159: @*/
160: PetscErrorCode FNSetOptionsPrefix(FN fn,const char *prefix)161: {
166: PetscObjectSetOptionsPrefix((PetscObject)fn,prefix);
167: return(0);
168: }
172: /*@C
173: FNAppendOptionsPrefix - Appends to the prefix used for searching for all
174: FN options in the database.
176: Logically Collective on FN178: Input Parameters:
179: + fn - the math function context
180: - prefix - the prefix string to prepend to all FN option requests
182: Notes:
183: A hyphen (-) must NOT be given at the beginning of the prefix name.
184: The first character of all runtime options is AUTOMATICALLY the hyphen.
186: Level: advanced
188: .seealso: FNSetOptionsPrefix()
189: @*/
190: PetscErrorCode FNAppendOptionsPrefix(FN fn,const char *prefix)191: {
196: PetscObjectAppendOptionsPrefix((PetscObject)fn,prefix);
197: return(0);
198: }
202: /*@C
203: FNGetOptionsPrefix - Gets the prefix used for searching for all
204: FN options in the database.
206: Not Collective
208: Input Parameters:
209: . fn - the math function context
211: Output Parameters:
212: . prefix - pointer to the prefix string used is returned
214: Notes: On the fortran side, the user should pass in a string 'prefix' of
215: sufficient length to hold the prefix.
217: Level: advanced
219: .seealso: FNSetOptionsPrefix(), FNAppendOptionsPrefix()
220: @*/
221: PetscErrorCode FNGetOptionsPrefix(FN fn,const char *prefix[])222: {
228: PetscObjectGetOptionsPrefix((PetscObject)fn,prefix);
229: return(0);
230: }
234: /*@C
235: FNSetType - Selects the type for the FN object.
237: Logically Collective on FN239: Input Parameter:
240: + fn - the math function context
241: - type - a known type
243: Notes:
244: The default is FNRATIONAL, which includes polynomials as a particular
245: case as well as simple functions such as f(x)=x and f(x)=constant.
247: Level: intermediate
249: .seealso: FNGetType()
250: @*/
251: PetscErrorCode FNSetType(FN fn,FNType type)252: {
253: PetscErrorCode ierr,(*r)(FN);
254: PetscBool match;
260: PetscObjectTypeCompare((PetscObject)fn,type,&match);
261: if (match) return(0);
263: PetscFunctionListFind(FNList,type,&r);
264: if (!r) SETERRQ1(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_UNKNOWN_TYPE,"Unable to find requested FN type %s",type);
266: if (fn->ops->destroy) { (*fn->ops->destroy)(fn); }
267: PetscMemzero(fn->ops,sizeof(struct _FNOps));
269: PetscObjectChangeTypeName((PetscObject)fn,type);
270: (*r)(fn);
271: return(0);
272: }
276: /*@C
277: FNGetType - Gets the FN type name (as a string) from the FN context.
279: Not Collective
281: Input Parameter:
282: . fn - the math function context
284: Output Parameter:
285: . name - name of the math function
287: Level: intermediate
289: .seealso: FNSetType()
290: @*/
291: PetscErrorCode FNGetType(FN fn,FNType *type)292: {
296: *type = ((PetscObject)fn)->type_name;
297: return(0);
298: }
302: /*@
303: FNSetScale - Sets the scaling parameters that define the matematical function.
305: Logically Collective on FN307: Input Parameters:
308: + fn - the math function context
309: . alpha - inner scaling (argument)
310: - beta - outer scaling (result)
312: Notes:
313: Given a function f(x) specified by the FN type, the scaling parameters can
314: be used to realize the function beta*f(alpha*x). So when these values are given,
315: the procedure for function evaluation will first multiply the argument by alpha,
316: then evaluate the function itself, and finally scale the result by beta.
317: Likewise, these values are also considered when evaluating the derivative.
319: If you want to provide only one of the two scaling factors, set the other
320: one to 1.0.
322: Level: intermediate
324: .seealso: FNGetScale(), FNEvaluateFunction()
325: @*/
326: PetscErrorCode FNSetScale(FN fn,PetscScalar alpha,PetscScalar beta)327: {
332: fn->alpha = alpha;
333: fn->beta = beta;
334: return(0);
335: }
339: /*@
340: FNGetScale - Gets the scaling parameters that define the matematical function.
342: Not Collective
344: Input Parameter:
345: . fn - the math function context
347: Output Parameters:
348: + alpha - inner scaling (argument)
349: - beta - outer scaling (result)
351: Level: intermediate
353: .seealso: FNSetScale()
354: @*/
355: PetscErrorCode FNGetScale(FN fn,PetscScalar *alpha,PetscScalar *beta)356: {
359: if (alpha) *alpha = fn->alpha;
360: if (beta) *beta = fn->beta;
361: return(0);
362: }
366: /*@
367: FNEvaluateFunction - Computes the value of the function f(x) for a given x.
369: Logically Collective on FN371: Input Parameters:
372: + fn - the math function context
373: - x - the value where the function must be evaluated
375: Output Parameter:
376: . y - the result of f(x)
378: Note:
379: Scaling factors are taken into account, so the actual function evaluation
380: will return beta*f(alpha*x).
382: Level: intermediate
384: .seealso: FNEvaluateDerivative(), FNEvaluateFunctionMat(), FNSetScale()
385: @*/
386: PetscErrorCode FNEvaluateFunction(FN fn,PetscScalar x,PetscScalar *y)387: {
389: PetscScalar xf,yf;
396: PetscLogEventBegin(FN_Evaluate,fn,0,0,0);
397: xf = fn->alpha*x;
398: (*fn->ops->evaluatefunction)(fn,xf,&yf);
399: *y = fn->beta*yf;
400: PetscLogEventEnd(FN_Evaluate,fn,0,0,0);
401: return(0);
402: }
406: /*@
407: FNEvaluateDerivative - Computes the value of the derivative f'(x) for a given x.
409: Logically Collective on FN411: Input Parameters:
412: + fn - the math function context
413: - x - the value where the derivative must be evaluated
415: Output Parameter:
416: . y - the result of f'(x)
418: Note:
419: Scaling factors are taken into account, so the actual derivative evaluation will
420: return alpha*beta*f'(alpha*x).
422: Level: intermediate
424: .seealso: FNEvaluateFunction()
425: @*/
426: PetscErrorCode FNEvaluateDerivative(FN fn,PetscScalar x,PetscScalar *y)427: {
429: PetscScalar xf,yf;
436: PetscLogEventBegin(FN_Evaluate,fn,0,0,0);
437: xf = fn->alpha*x;
438: (*fn->ops->evaluatederivative)(fn,xf,&yf);
439: *y = fn->alpha*fn->beta*yf;
440: PetscLogEventEnd(FN_Evaluate,fn,0,0,0);
441: return(0);
442: }
446: /*
447: FNEvaluateFunctionMat_Sym_Default - given a symmetric matrix A,
448: compute the matrix function as f(A)=Q*f(D)*Q' where the spectral
449: decomposition of A is A=Q*D*Q'
450: */
451: static PetscErrorCode FNEvaluateFunctionMat_Sym_Default(FN fn,Mat A,Mat B)452: {
453: #if defined(PETSC_MISSING_LAPACK_SYEV)
455: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"SYEV - Lapack routines are unavailable");
456: #else
458: PetscInt i,j,m;
459: PetscBLASInt n,ld,lwork,info;
460: PetscScalar *As,*Bs,*Q,*W,*work,a,x,y,one=1.0,zero=0.0;
461: PetscReal *eig;
462: #if defined(PETSC_USE_COMPLEX)
463: PetscReal *rwork;
464: #endif
467: MatDenseGetArray(A,&As);
468: MatDenseGetArray(B,&Bs);
469: MatGetSize(A,&m,NULL);
470: PetscBLASIntCast(m,&n);
471: ld = n;
473: /* workspace query and memory allocation */
474: lwork = -1;
475: #if defined(PETSC_USE_COMPLEX)
476: PetscStackCallBLAS("LAPACKsyev",LAPACKsyev_("V","L",&n,As,&ld,NULL,&a,&lwork,NULL,&info));
477: PetscBLASIntCast((PetscInt)PetscRealPart(a),&lwork);
478: PetscMalloc5(m,&eig,m*m,&Q,m*m,&W,lwork,&work,PetscMax(1,3*m-2),&rwork);
479: #else
480: PetscStackCallBLAS("LAPACKsyev",LAPACKsyev_("V","L",&n,As,&ld,NULL,&a,&lwork,&info));
481: PetscBLASIntCast((PetscInt)PetscRealPart(a),&lwork);
482: PetscMalloc4(m,&eig,m*m,&Q,m*m,&W,lwork,&work);
483: #endif
485: /* compute eigendecomposition */
486: PetscStackCallBLAS("LAPACKlacpy",LAPACKlacpy_("L",&n,&n,As,&ld,Q,&ld));
487: #if defined(PETSC_USE_COMPLEX)
488: PetscStackCallBLAS("LAPACKsyev",LAPACKsyev_("V","L",&n,Q,&ld,eig,work,&lwork,rwork,&info));
489: #else
490: PetscStackCallBLAS("LAPACKsyev",LAPACKsyev_("V","L",&n,Q,&ld,eig,work,&lwork,&info));
491: #endif
492: if (info) SETERRQ1(PetscObjectComm((PetscObject)fn),PETSC_ERR_LIB,"Error in Lapack xSYEV %i",info);
494: /* W = f(Lambda)*Q' */
495: for (i=0;i<n;i++) {
496: x = eig[i];
497: (*fn->ops->evaluatefunction)(fn,x,&y); /* y = f(x) */
498: for (j=0;j<n;j++) W[i+j*ld] = Q[j+i*ld]*y;
499: }
500: /* Bs = Q*W */
501: PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&n,&n,&n,&one,Q,&ld,W,&ld,&zero,Bs,&ld));
502: #if defined(PETSC_USE_COMPLEX)
503: PetscFree5(eig,Q,W,work,rwork);
504: #else
505: PetscFree4(eig,Q,W,work);
506: #endif
507: MatDenseRestoreArray(A,&As);
508: MatDenseRestoreArray(B,&Bs);
509: return(0);
510: #endif
511: }
515: /*@
516: FNEvaluateFunctionMat - Computes the value of the function f(A) for a given
517: matrix A, where the result is also a matrix.
519: Logically Collective on FN521: Input Parameters:
522: + fn - the math function context
523: - A - matrix on which the function must be evaluated
525: Output Parameter:
526: . B - matrix resulting from evaluating f(A)
528: Notes:
529: The matrix A must be a sequential dense Mat, with all entries equal on
530: all processes (otherwise each process will compute different results).
531: Matrix B must also be a sequential dense Mat. Both matrices must be
532: square with the same dimensions.
534: If A is known to be real symmetric or complex Hermitian then it is
535: recommended to set the appropriate flag with MatSetOption(), so that
536: a different algorithm that exploits symmetry is used.
538: Scaling factors are taken into account, so the actual function evaluation
539: will return beta*f(alpha*A).
541: Level: advanced
543: .seealso: FNEvaluateFunction()
544: @*/
545: PetscErrorCode FNEvaluateFunctionMat(FN fn,Mat A,Mat B)546: {
548: PetscBool match,set,flg,symm=PETSC_FALSE;
549: PetscInt m,n,n1;
550: Mat M;
559: if (A==B) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_WRONG,"A and B arguments must be different");
560: PetscObjectTypeCompare((PetscObject)A,MATSEQDENSE,&match);
561: if (!match) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_SUP,"Mat A must be of type seqdense");
562: PetscObjectTypeCompare((PetscObject)B,MATSEQDENSE,&match);
563: if (!match) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_SUP,"Mat B must be of type seqdense");
564: MatGetSize(A,&m,&n);
565: if (m!=n) SETERRQ2(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_SIZ,"Mat A is not square (has %D rows, %D cols)",m,n);
566: n1 = n;
567: MatGetSize(B,&m,&n);
568: if (m!=n) SETERRQ2(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_SIZ,"Mat B is not square (has %D rows, %D cols)",m,n);
569: if (n1!=n) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_SIZ,"Matrices A and B must have the same dimension");
571: /* check symmetry of A */
572: MatIsHermitianKnown(A,&set,&flg);
573: symm = set? flg: PETSC_FALSE;
575: /* scale argument */
576: if (fn->alpha!=(PetscScalar)1.0) {
577: FN_AllocateWorkMat(fn,A);
578: M = fn->W;
579: MatScale(M,fn->alpha);
580: } else M = A;
582: /* evaluate matrix function */
583: PetscLogEventBegin(FN_Evaluate,fn,0,0,0);
584: PetscFPTrapPush(PETSC_FP_TRAP_OFF);
585: if (symm) {
586: if (fn->ops->evaluatefunctionmatsym) {
587: (*fn->ops->evaluatefunctionmatsym)(fn,M,B);
588: } else {
589: FNEvaluateFunctionMat_Sym_Default(fn,M,B);
590: }
591: } else {
592: if (fn->ops->evaluatefunctionmat) {
593: (*fn->ops->evaluatefunctionmat)(fn,M,B);
594: } else SETERRQ1(PetscObjectComm((PetscObject)fn),PETSC_ERR_SUP,"Matrix functions not implemented in FN type %s",((PetscObject)fn)->type_name);
595: }
596: PetscFPTrapPop();
597: PetscLogEventEnd(FN_Evaluate,fn,0,0,0);
599: /* scale result */
600: MatScale(B,fn->beta);
601: return(0);
602: }
606: /*@
607: FNSetFromOptions - Sets FN options from the options database.
609: Collective on FN611: Input Parameters:
612: . fn - the math function context
614: Notes:
615: To see all options, run your program with the -help option.
617: Level: beginner
618: @*/
619: PetscErrorCode FNSetFromOptions(FN fn)620: {
622: char type[256];
623: PetscScalar array[2];
624: PetscInt k;
625: PetscBool flg;
629: FNRegisterAll();
630: PetscObjectOptionsBegin((PetscObject)fn);
631: PetscOptionsFList("-fn_type","Math function type","FNSetType",FNList,(char*)(((PetscObject)fn)->type_name?((PetscObject)fn)->type_name:FNRATIONAL),type,256,&flg);
632: if (flg) {
633: FNSetType(fn,type);
634: }
635: /*
636: Set the type if it was never set.
637: */
638: if (!((PetscObject)fn)->type_name) {
639: FNSetType(fn,FNRATIONAL);
640: }
642: k = 2;
643: array[0] = 0.0; array[1] = 0.0;
644: PetscOptionsScalarArray("-fn_scale","Scale factors (one or two scalar values separated with a comma without spaces)","FNSetScale",array,&k,&flg);
645: if (flg) {
646: if (k<2) array[1] = 1.0;
647: FNSetScale(fn,array[0],array[1]);
648: }
650: if (fn->ops->setfromoptions) {
651: (*fn->ops->setfromoptions)(PetscOptionsObject,fn);
652: }
653: PetscObjectProcessOptionsHandlers((PetscObject)fn);
654: PetscOptionsEnd();
655: return(0);
656: }
660: /*@C
661: FNView - Prints the FN data structure.
663: Collective on FN665: Input Parameters:
666: + fn - the math function context
667: - viewer - optional visualization context
669: Note:
670: The available visualization contexts include
671: + PETSC_VIEWER_STDOUT_SELF - standard output (default)
672: - PETSC_VIEWER_STDOUT_WORLD - synchronized standard
673: output where only the first processor opens
674: the file. All other processors send their
675: data to the first processor to print.
677: The user can open an alternative visualization context with
678: PetscViewerASCIIOpen() - output to a specified file.
680: Level: beginner
681: @*/
682: PetscErrorCode FNView(FN fn,PetscViewer viewer)683: {
684: PetscBool isascii;
689: if (!viewer) viewer = PETSC_VIEWER_STDOUT_(PetscObjectComm((PetscObject)fn));
692: PetscObjectTypeCompare((PetscObject)viewer,PETSCVIEWERASCII,&isascii);
693: if (isascii) {
694: PetscObjectPrintClassNamePrefixType((PetscObject)fn,viewer);
695: if (fn->ops->view) {
696: PetscViewerASCIIPushTab(viewer);
697: (*fn->ops->view)(fn,viewer);
698: PetscViewerASCIIPopTab(viewer);
699: }
700: }
701: return(0);
702: }
706: /*@
707: FNDuplicate - Duplicates a math function, copying all parameters, possibly with a
708: different communicator.
710: Collective on FN712: Input Parameters:
713: + fn - the math function context
714: - comm - MPI communicator (may be NULL)
716: Output Parameter:
717: . newfn - location to put the new FN context
719: Level: developer
721: .seealso: FNCreate()
722: @*/
723: PetscErrorCode FNDuplicate(FN fn,MPI_Comm comm,FN *newfn)724: {
726: FNType type;
727: PetscScalar alpha,beta;
733: if (!comm) comm = PetscObjectComm((PetscObject)fn);
734: FNCreate(comm,newfn);
735: FNGetType(fn,&type);
736: FNSetType(*newfn,type);
737: FNGetScale(fn,&alpha,&beta);
738: FNSetScale(*newfn,alpha,beta);
739: if (fn->ops->duplicate) {
740: (*fn->ops->duplicate)(fn,comm,newfn);
741: }
742: return(0);
743: }
747: /*@
748: FNDestroy - Destroys FN context that was created with FNCreate().
750: Collective on FN752: Input Parameter:
753: . fn - the math function context
755: Level: beginner
757: .seealso: FNCreate()
758: @*/
759: PetscErrorCode FNDestroy(FN *fn)760: {
764: if (!*fn) return(0);
766: if (--((PetscObject)(*fn))->refct > 0) { *fn = 0; return(0); }
767: if ((*fn)->ops->destroy) { (*(*fn)->ops->destroy)(*fn); }
768: MatDestroy(&(*fn)->W);
769: PetscHeaderDestroy(fn);
770: return(0);
771: }
775: /*@C
776: FNRegister - See Adds a mathematical function to the FN package.
778: Not collective
780: Input Parameters:
781: + name - name of a new user-defined FN782: - function - routine to create context
784: Notes:
785: FNRegister() may be called multiple times to add several user-defined inner products.
787: Level: advanced
789: .seealso: FNRegisterAll()
790: @*/
791: PetscErrorCode FNRegister(const char *name,PetscErrorCode (*function)(FN))792: {
796: PetscFunctionListAdd(&FNList,name,function);
797: return(0);
798: }