Date: 2021-02-01T14:41:40+00:00

Actual source code: fnbasic.c
slepc-3.14.2 2021-02-01
Report Typos and Errors

      1: /*
      2:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      3:    SLEPc - Scalable Library for Eigenvalue Problem Computations
      4:    Copyright (c) 2002-2020, 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: */
     10: /*
     11:    Basic FN routines
     12: */

     14: #include <slepc/private/fnimpl.h>
     15: #include <slepcblaslapack.h>

     17: PetscFunctionList FNList = 0;
     18: PetscBool         FNRegisterAllCalled = PETSC_FALSE;
     19: PetscClassId      FN_CLASSID = 0;
     20: PetscLogEvent     FN_Evaluate = 0;
     21: static PetscBool  FNPackageInitialized = PETSC_FALSE;

     23: const char *FNParallelTypes[] = {"REDUNDANT","SYNCHRONIZED","FNParallelType","FN_PARALLEL_",0};

     25: /*@C
     26:    FNFinalizePackage - This function destroys everything in the Slepc interface
     27:    to the FN package. It is called from SlepcFinalize().

     29:    Level: developer

     31: .seealso: SlepcFinalize()
     32: @*/
     33: PetscErrorCode FNFinalizePackage(void)
     34: {

     38:   PetscFunctionListDestroy(&FNList);
     39:   FNPackageInitialized = PETSC_FALSE;
     40:   FNRegisterAllCalled  = PETSC_FALSE;
     41:   return(0);
     42: }

     44: /*@C
     45:   FNInitializePackage - This function initializes everything in the FN package.
     46:   It is called from PetscDLLibraryRegister() when using dynamic libraries, and
     47:   on the first call to FNCreate() when using static libraries.

     49:   Level: developer

     51: .seealso: SlepcInitialize()
     52: @*/
     53: PetscErrorCode FNInitializePackage(void)
     54: {
     55:   char           logList[256];
     56:   PetscBool      opt,pkg;
     57:   PetscClassId   classids[1];

     61:   if (FNPackageInitialized) return(0);
     62:   FNPackageInitialized = PETSC_TRUE;
     63:   /* Register Classes */
     64:   PetscClassIdRegister("Math Function",&FN_CLASSID);
     65:   /* Register Constructors */
     66:   FNRegisterAll();
     67:   /* Register Events */
     68:   PetscLogEventRegister("FNEvaluate",FN_CLASSID,&FN_Evaluate);
     69:   /* Process Info */
     70:   classids[0] = FN_CLASSID;
     71:   PetscInfoProcessClass("fn",1,&classids[0]);
     72:   /* Process summary exclusions */
     73:   PetscOptionsGetString(NULL,NULL,"-log_exclude",logList,sizeof(logList),&opt);
     74:   if (opt) {
     75:     PetscStrInList("fn",logList,',',&pkg);
     76:     if (pkg) { PetscLogEventDeactivateClass(FN_CLASSID); }
     77:   }
     78:   /* Register package finalizer */
     79:   PetscRegisterFinalize(FNFinalizePackage);
     80:   return(0);
     81: }

     83: /*@
     84:    FNCreate - Creates an FN context.

     86:    Collective

     88:    Input Parameter:
     89: .  comm - MPI communicator

     91:    Output Parameter:
     92: .  newfn - location to put the FN context

     94:    Level: beginner

     96: .seealso: FNDestroy(), FN
     97: @*/
     98: PetscErrorCode FNCreate(MPI_Comm comm,FN *newfn)
     99: {
    100:   FN             fn;

    105:   *newfn = 0;
    106:   FNInitializePackage();
    107:   SlepcHeaderCreate(fn,FN_CLASSID,"FN","Math Function","FN",comm,FNDestroy,FNView);

    109:   fn->alpha    = 1.0;
    110:   fn->beta     = 1.0;
    111:   fn->method   = 0;

    113:   fn->nw       = 0;
    114:   fn->cw       = 0;
    115:   fn->data     = NULL;

    117:   *newfn = fn;
    118:   return(0);
    119: }

    121: /*@C
    122:    FNSetOptionsPrefix - Sets the prefix used for searching for all
    123:    FN options in the database.

    125:    Logically Collective on fn

    127:    Input Parameters:
    128: +  fn - the math function context
    129: -  prefix - the prefix string to prepend to all FN option requests

    131:    Notes:
    132:    A hyphen (-) must NOT be given at the beginning of the prefix name.
    133:    The first character of all runtime options is AUTOMATICALLY the
    134:    hyphen.

    136:    Level: advanced

    138: .seealso: FNAppendOptionsPrefix()
    139: @*/
    140: PetscErrorCode FNSetOptionsPrefix(FN fn,const char *prefix)
    141: {

    146:   PetscObjectSetOptionsPrefix((PetscObject)fn,prefix);
    147:   return(0);
    148: }

    150: /*@C
    151:    FNAppendOptionsPrefix - Appends to the prefix used for searching for all
    152:    FN options in the database.

    154:    Logically Collective on fn

    156:    Input Parameters:
    157: +  fn - the math function context
    158: -  prefix - the prefix string to prepend to all FN option requests

    160:    Notes:
    161:    A hyphen (-) must NOT be given at the beginning of the prefix name.
    162:    The first character of all runtime options is AUTOMATICALLY the hyphen.

    164:    Level: advanced

    166: .seealso: FNSetOptionsPrefix()
    167: @*/
    168: PetscErrorCode FNAppendOptionsPrefix(FN fn,const char *prefix)
    169: {

    174:   PetscObjectAppendOptionsPrefix((PetscObject)fn,prefix);
    175:   return(0);
    176: }

    178: /*@C
    179:    FNGetOptionsPrefix - Gets the prefix used for searching for all
    180:    FN options in the database.

    182:    Not Collective

    184:    Input Parameters:
    185: .  fn - the math function context

    187:    Output Parameters:
    188: .  prefix - pointer to the prefix string used is returned

    190:    Note:
    191:    On the Fortran side, the user should pass in a string 'prefix' of
    192:    sufficient length to hold the prefix.

    194:    Level: advanced

    196: .seealso: FNSetOptionsPrefix(), FNAppendOptionsPrefix()
    197: @*/
    198: PetscErrorCode FNGetOptionsPrefix(FN fn,const char *prefix[])
    199: {

    205:   PetscObjectGetOptionsPrefix((PetscObject)fn,prefix);
    206:   return(0);
    207: }

    209: /*@C
    210:    FNSetType - Selects the type for the FN object.

    212:    Logically Collective on fn

    214:    Input Parameter:
    215: +  fn   - the math function context
    216: -  type - a known type

    218:    Notes:
    219:    The default is FNRATIONAL, which includes polynomials as a particular
    220:    case as well as simple functions such as f(x)=x and f(x)=constant.

    222:    Level: intermediate

    224: .seealso: FNGetType()
    225: @*/
    226: PetscErrorCode FNSetType(FN fn,FNType type)
    227: {
    228:   PetscErrorCode ierr,(*r)(FN);
    229:   PetscBool      match;

    235:   PetscObjectTypeCompare((PetscObject)fn,type,&match);
    236:   if (match) return(0);

    238:    PetscFunctionListFind(FNList,type,&r);
    239:   if (!r) SETERRQ1(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_UNKNOWN_TYPE,"Unable to find requested FN type %s",type);

    241:   if (fn->ops->destroy) { (*fn->ops->destroy)(fn); }
    242:   PetscMemzero(fn->ops,sizeof(struct _FNOps));

    244:   PetscObjectChangeTypeName((PetscObject)fn,type);
    245:   (*r)(fn);
    246:   return(0);
    247: }

    249: /*@C
    250:    FNGetType - Gets the FN type name (as a string) from the FN context.

    252:    Not Collective

    254:    Input Parameter:
    255: .  fn - the math function context

    257:    Output Parameter:
    258: .  name - name of the math function

    260:    Level: intermediate

    262: .seealso: FNSetType()
    263: @*/
    264: PetscErrorCode FNGetType(FN fn,FNType *type)
    265: {
    269:   *type = ((PetscObject)fn)->type_name;
    270:   return(0);
    271: }

    273: /*@
    274:    FNSetScale - Sets the scaling parameters that define the matematical function.

    276:    Logically Collective on fn

    278:    Input Parameters:
    279: +  fn    - the math function context
    280: .  alpha - inner scaling (argument)
    281: -  beta  - outer scaling (result)

    283:    Notes:
    284:    Given a function f(x) specified by the FN type, the scaling parameters can
    285:    be used to realize the function beta*f(alpha*x). So when these values are given,
    286:    the procedure for function evaluation will first multiply the argument by alpha,
    287:    then evaluate the function itself, and finally scale the result by beta.
    288:    Likewise, these values are also considered when evaluating the derivative.

    290:    If you want to provide only one of the two scaling factors, set the other
    291:    one to 1.0.

    293:    Level: intermediate

    295: .seealso: FNGetScale(), FNEvaluateFunction()
    296: @*/
    297: PetscErrorCode FNSetScale(FN fn,PetscScalar alpha,PetscScalar beta)
    298: {
    303:   if (PetscAbsScalar(alpha)==0.0 || PetscAbsScalar(beta)==0.0) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_WRONG,"Scaling factors must be nonzero");
    304:   fn->alpha = alpha;
    305:   fn->beta  = beta;
    306:   return(0);
    307: }

    309: /*@
    310:    FNGetScale - Gets the scaling parameters that define the matematical function.

    312:    Not Collective

    314:    Input Parameter:
    315: .  fn    - the math function context

    317:    Output Parameters:
    318: +  alpha - inner scaling (argument)
    319: -  beta  - outer scaling (result)

    321:    Level: intermediate

    323: .seealso: FNSetScale()
    324: @*/
    325: PetscErrorCode FNGetScale(FN fn,PetscScalar *alpha,PetscScalar *beta)
    326: {
    329:   if (alpha) *alpha = fn->alpha;
    330:   if (beta)  *beta  = fn->beta;
    331:   return(0);
    332: }

    334: /*@
    335:    FNSetMethod - Selects the method to be used to evaluate functions of matrices.

    337:    Logically Collective on fn

    339:    Input Parameter:
    340: +  fn   - the math function context
    341: -  meth - an index indentifying the method

    343:    Options Database Key:
    344: .  -fn_method <meth> - Sets the method

    346:    Notes:
    347:    In some FN types there are more than one algorithms available for computing
    348:    matrix functions. In that case, this function allows choosing the wanted method.

    350:    If meth is currently set to 0 (the default) and the input argument A of
    351:    FNEvaluateFunctionMat() is a symmetric/Hermitian matrix, then the computation
    352:    is done via the eigendecomposition of A, rather than with the general algorithm.

    354:    Level: intermediate

    356: .seealso: FNGetMethod(), FNEvaluateFunctionMat()
    357: @*/
    358: PetscErrorCode FNSetMethod(FN fn,PetscInt meth)
    359: {
    363:   if (meth<0) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_OUTOFRANGE,"The method must be a non-negative integer");
    364:   if (meth>FN_MAX_SOLVE) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_OUTOFRANGE,"Too large value for the method");
    365:   fn->method = meth;
    366:   return(0);
    367: }

    369: /*@
    370:    FNGetMethod - Gets the method currently used in the FN.

    372:    Not Collective

    374:    Input Parameter:
    375: .  fn - the math function context

    377:    Output Parameter:
    378: .  meth - identifier of the method

    380:    Level: intermediate

    382: .seealso: FNSetMethod()
    383: @*/
    384: PetscErrorCode FNGetMethod(FN fn,PetscInt *meth)
    385: {
    389:   *meth = fn->method;
    390:   return(0);
    391: }

    393: /*@
    394:    FNSetParallel - Selects the mode of operation in parallel runs.

    396:    Logically Collective on fn

    398:    Input Parameter:
    399: +  fn    - the math function context
    400: -  pmode - the parallel mode

    402:    Options Database Key:
    403: .  -fn_parallel <mode> - Sets the parallel mode, either 'redundant' or 'synchronized'

    405:    Notes:
    406:    This is relevant only when the function is evaluated on a matrix, with
    407:    either FNEvaluateFunctionMat() or FNEvaluateFunctionMatVec().

    409:    In the 'redundant' parallel mode, all processes will make the computation
    410:    redundantly, starting from the same data, and producing the same result.
    411:    This result may be slightly different in the different processes if using a
    412:    multithreaded BLAS library, which may cause issues in ill-conditioned problems.

    414:    In the 'synchronized' parallel mode, only the first MPI process performs the
    415:    computation and then the computed matrix is broadcast to the other
    416:    processes in the communicator. This communication is done automatically at
    417:    the end of FNEvaluateFunctionMat() or FNEvaluateFunctionMatVec().

    419:    Level: advanced

    421: .seealso: FNEvaluateFunctionMat() or FNEvaluateFunctionMatVec(), FNGetParallel()
    422: @*/
    423: PetscErrorCode FNSetParallel(FN fn,FNParallelType pmode)
    424: {
    428:   fn->pmode = pmode;
    429:   return(0);
    430: }

    432: /*@
    433:    FNGetParallel - Gets the mode of operation in parallel runs.

    435:    Not Collective

    437:    Input Parameter:
    438: .  fn - the math function context

    440:    Output Parameter:
    441: .  pmode - the parallel mode

    443:    Level: advanced

    445: .seealso: FNSetParallel()
    446: @*/
    447: PetscErrorCode FNGetParallel(FN fn,FNParallelType *pmode)
    448: {
    452:   *pmode = fn->pmode;
    453:   return(0);
    454: }

    456: /*@
    457:    FNEvaluateFunction - Computes the value of the function f(x) for a given x.

    459:    Not collective

    461:    Input Parameters:
    462: +  fn - the math function context
    463: -  x  - the value where the function must be evaluated

    465:    Output Parameter:
    466: .  y  - the result of f(x)

    468:    Note:
    469:    Scaling factors are taken into account, so the actual function evaluation
    470:    will return beta*f(alpha*x).

    472:    Level: intermediate

    474: .seealso: FNEvaluateDerivative(), FNEvaluateFunctionMat(), FNSetScale()
    475: @*/
    476: PetscErrorCode FNEvaluateFunction(FN fn,PetscScalar x,PetscScalar *y)
    477: {
    479:   PetscScalar    xf,yf;

    485:   PetscLogEventBegin(FN_Evaluate,fn,0,0,0);
    486:   xf = fn->alpha*x;
    487:   (*fn->ops->evaluatefunction)(fn,xf,&yf);
    488:   *y = fn->beta*yf;
    489:   PetscLogEventEnd(FN_Evaluate,fn,0,0,0);
    490:   return(0);
    491: }

    493: /*@
    494:    FNEvaluateDerivative - Computes the value of the derivative f'(x) for a given x.

    496:    Not Collective

    498:    Input Parameters:
    499: +  fn - the math function context
    500: -  x  - the value where the derivative must be evaluated

    502:    Output Parameter:
    503: .  y  - the result of f'(x)

    505:    Note:
    506:    Scaling factors are taken into account, so the actual derivative evaluation will
    507:    return alpha*beta*f'(alpha*x).

    509:    Level: intermediate

    511: .seealso: FNEvaluateFunction()
    512: @*/
    513: PetscErrorCode FNEvaluateDerivative(FN fn,PetscScalar x,PetscScalar *y)
    514: {
    516:   PetscScalar    xf,yf;

    522:   PetscLogEventBegin(FN_Evaluate,fn,0,0,0);
    523:   xf = fn->alpha*x;
    524:   (*fn->ops->evaluatederivative)(fn,xf,&yf);
    525:   *y = fn->alpha*fn->beta*yf;
    526:   PetscLogEventEnd(FN_Evaluate,fn,0,0,0);
    527:   return(0);
    528: }

    530: static PetscErrorCode FNEvaluateFunctionMat_Sym_Private(FN fn,PetscScalar *As,PetscScalar *Bs,PetscInt m,PetscBool firstonly)
    531: {
    533:   PetscInt       i,j;
    534:   PetscBLASInt   n,k,ld,lwork,info;
    535:   PetscScalar    *Q,*W,*work,a,x,y,one=1.0,zero=0.0;
    536:   PetscReal      *eig,dummy;
    537: #if defined(PETSC_USE_COMPLEX)
    538:   PetscReal      *rwork,rdummy;
    539: #endif

    542:   PetscBLASIntCast(m,&n);
    543:   ld = n;
    544:   k = firstonly? 1: n;

    546:   /* workspace query and memory allocation */
    547:   lwork = -1;
    548: #if defined(PETSC_USE_COMPLEX)
    549:   PetscStackCallBLAS("LAPACKsyev",LAPACKsyev_("V","L",&n,As,&ld,&dummy,&a,&lwork,&rdummy,&info));
    550:   PetscBLASIntCast((PetscInt)PetscRealPart(a),&lwork);
    551:   PetscMalloc5(m,&eig,m*m,&Q,m*k,&W,lwork,&work,PetscMax(1,3*m-2),&rwork);
    552: #else
    553:   PetscStackCallBLAS("LAPACKsyev",LAPACKsyev_("V","L",&n,As,&ld,&dummy,&a,&lwork,&info));
    554:   PetscBLASIntCast((PetscInt)a,&lwork);
    555:   PetscMalloc4(m,&eig,m*m,&Q,m*k,&W,lwork,&work);
    556: #endif

    558:   /* compute eigendecomposition */
    559:   for (j=0;j<n;j++) for (i=j;i<n;i++) Q[i+j*ld] = As[i+j*ld];
    560: #if defined(PETSC_USE_COMPLEX)
    561:   PetscStackCallBLAS("LAPACKsyev",LAPACKsyev_("V","L",&n,Q,&ld,eig,work,&lwork,rwork,&info));
    562: #else
    563:   PetscStackCallBLAS("LAPACKsyev",LAPACKsyev_("V","L",&n,Q,&ld,eig,work,&lwork,&info));
    564: #endif
    565:   SlepcCheckLapackInfo("syev",info);

    567:   /* W = f(Lambda)*Q' */
    568:   for (i=0;i<n;i++) {
    569:     x = fn->alpha*eig[i];
    570:     (*fn->ops->evaluatefunction)(fn,x,&y);  /* y = f(x) */
    571:     for (j=0;j<k;j++) W[i+j*ld] = PetscConj(Q[j+i*ld])*fn->beta*y;
    572:   }
    573:   /* Bs = Q*W */
    574:   PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&n,&k,&n,&one,Q,&ld,W,&ld,&zero,Bs,&ld));
    575: #if defined(PETSC_USE_COMPLEX)
    576:   PetscFree5(eig,Q,W,work,rwork);
    577: #else
    578:   PetscFree4(eig,Q,W,work);
    579: #endif
    580:   PetscLogFlops(9.0*n*n*n+2.0*n*n*n);
    581:   return(0);
    582: }

    584: /*
    585:    FNEvaluateFunctionMat_Sym_Default - given a symmetric matrix A,
    586:    compute the matrix function as f(A)=Q*f(D)*Q' where the spectral
    587:    decomposition of A is A=Q*D*Q'
    588: */
    589: static PetscErrorCode FNEvaluateFunctionMat_Sym_Default(FN fn,Mat A,Mat B)
    590: {
    592:   PetscInt       m;
    593:   PetscScalar    *As,*Bs;

    596:   MatDenseGetArray(A,&As);
    597:   MatDenseGetArray(B,&Bs);
    598:   MatGetSize(A,&m,NULL);
    599:   FNEvaluateFunctionMat_Sym_Private(fn,As,Bs,m,PETSC_FALSE);
    600:   MatDenseRestoreArray(A,&As);
    601:   MatDenseRestoreArray(B,&Bs);
    602:   return(0);
    603: }

    605: PetscErrorCode FNEvaluateFunctionMat_Private(FN fn,Mat A,Mat B,PetscBool sync)
    606: {
    608:   PetscBool      set,flg,symm=PETSC_FALSE;
    609:   PetscInt       m,n;
    610:   PetscMPIInt    size,rank;
    611:   PetscScalar    *pF;
    612:   Mat            M,F;

    615:   /* destination matrix */
    616:   F = B?B:A;

    618:   /* check symmetry of A */
    619:   MatIsHermitianKnown(A,&set,&flg);
    620:   symm = set? flg: PETSC_FALSE;

    622:   MPI_Comm_size(PetscObjectComm((PetscObject)fn),&size);
    623:   MPI_Comm_rank(PetscObjectComm((PetscObject)fn),&rank);
    624:   if (size==1 || fn->pmode==FN_PARALLEL_REDUNDANT || (fn->pmode==FN_PARALLEL_SYNCHRONIZED && !rank)) {

    626:     PetscFPTrapPush(PETSC_FP_TRAP_OFF);
    627:     if (symm && !fn->method) {  /* prefer diagonalization */
    628:       PetscInfo(fn,"Computing matrix function via diagonalization\n");
    629:       FNEvaluateFunctionMat_Sym_Default(fn,A,F);
    630:     } else {
    631:       /* scale argument */
    632:       if (fn->alpha!=(PetscScalar)1.0) {
    633:         FN_AllocateWorkMat(fn,A,&M);
    634:         MatScale(M,fn->alpha);
    635:       } else M = A;
    636:       if (fn->ops->evaluatefunctionmat[fn->method]) {
    637:         (*fn->ops->evaluatefunctionmat[fn->method])(fn,M,F);
    638:       } else if (!fn->method) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_SUP,"Matrix functions not implemented in this FN type");
    639:       else SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_OUTOFRANGE,"The specified method number does not exist for this FN type");
    640:       if (fn->alpha!=(PetscScalar)1.0) {
    641:         FN_FreeWorkMat(fn,&M);
    642:       }
    643:       /* scale result */
    644:       MatScale(F,fn->beta);
    645:     }
    646:     PetscFPTrapPop();
    647:   }
    648:   if (size>1 && fn->pmode==FN_PARALLEL_SYNCHRONIZED && sync) {  /* synchronize */
    649:     MatGetSize(A,&m,&n);
    650:     MatDenseGetArray(F,&pF);
    651:     MPI_Bcast(pF,n*n,MPIU_SCALAR,0,PetscObjectComm((PetscObject)fn));
    652:     MatDenseRestoreArray(F,&pF);
    653:   }
    654:   return(0);
    655: }

    657: /*@
    658:    FNEvaluateFunctionMat - Computes the value of the function f(A) for a given
    659:    matrix A, where the result is also a matrix.

    661:    Logically Collective on fn

    663:    Input Parameters:
    664: +  fn - the math function context
    665: -  A  - matrix on which the function must be evaluated

    667:    Output Parameter:
    668: .  B  - (optional) matrix resulting from evaluating f(A)

    670:    Notes:
    671:    Matrix A must be a square sequential dense Mat, with all entries equal on
    672:    all processes (otherwise each process will compute different results).
    673:    If matrix B is provided, it must also be a square sequential dense Mat, and
    674:    both matrices must have the same dimensions. If B is NULL (or B=A) then the
    675:    function will perform an in-place computation, overwriting A with f(A).

    677:    If A is known to be real symmetric or complex Hermitian then it is
    678:    recommended to set the appropriate flag with MatSetOption(), because
    679:    symmetry can sometimes be exploited by the algorithm.

    681:    Scaling factors are taken into account, so the actual function evaluation
    682:    will return beta*f(alpha*A).

    684:    Level: advanced

    686: .seealso: FNEvaluateFunction(), FNEvaluateFunctionMatVec(), FNSetMethod()
    687: @*/
    688: PetscErrorCode FNEvaluateFunctionMat(FN fn,Mat A,Mat B)
    689: {
    691:   PetscBool      match,inplace=PETSC_FALSE;
    692:   PetscInt       m,n,n1;

    699:   if (B) {
    702:   } else inplace = PETSC_TRUE;
    703:   PetscObjectTypeCompare((PetscObject)A,MATSEQDENSE,&match);
    704:   if (!match) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_SUP,"Mat A must be of type seqdense");
    705:   MatGetSize(A,&m,&n);
    706:   if (m!=n) SETERRQ2(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_SIZ,"Mat A is not square (has %D rows, %D cols)",m,n);
    707:   if (!inplace) {
    708:     PetscObjectTypeCompare((PetscObject)B,MATSEQDENSE,&match);
    709:     if (!match) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_SUP,"Mat B must be of type seqdense");
    710:     n1 = n;
    711:     MatGetSize(B,&m,&n);
    712:     if (m!=n) SETERRQ2(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_SIZ,"Mat B is not square (has %D rows, %D cols)",m,n);
    713:     if (n1!=n) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_SIZ,"Matrices A and B must have the same dimension");
    714:   }

    716:   /* evaluate matrix function */
    717:   PetscLogEventBegin(FN_Evaluate,fn,0,0,0);
    718:   FNEvaluateFunctionMat_Private(fn,A,B,PETSC_TRUE);
    719:   PetscLogEventEnd(FN_Evaluate,fn,0,0,0);
    720:   return(0);
    721: }

    723: /*
    724:    FNEvaluateFunctionMatVec_Default - computes the full matrix f(A)
    725:    and then copies the first column.
    726: */
    727: static PetscErrorCode FNEvaluateFunctionMatVec_Default(FN fn,Mat A,Vec v)
    728: {
    730:   Mat            F;

    733:   FN_AllocateWorkMat(fn,A,&F);
    734:   if (fn->ops->evaluatefunctionmat[fn->method]) {
    735:     (*fn->ops->evaluatefunctionmat[fn->method])(fn,A,F);
    736:   } else if (!fn->method) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_SUP,"Matrix functions not implemented in this FN type");
    737:   else SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_OUTOFRANGE,"The specified method number does not exist for this FN type");
    738:   MatGetColumnVector(F,v,0);
    739:   FN_FreeWorkMat(fn,&F);
    740:   return(0);
    741: }

    743: /*
    744:    FNEvaluateFunctionMatVec_Sym_Default - given a symmetric matrix A,
    745:    compute the matrix function as f(A)=Q*f(D)*Q' where the spectral
    746:    decomposition of A is A=Q*D*Q'. Only the first column is computed.
    747: */
    748: static PetscErrorCode FNEvaluateFunctionMatVec_Sym_Default(FN fn,Mat A,Vec v)
    749: {
    751:   PetscInt       m;
    752:   PetscScalar    *As,*vs;

    755:   MatDenseGetArray(A,&As);
    756:   VecGetArray(v,&vs);
    757:   MatGetSize(A,&m,NULL);
    758:   FNEvaluateFunctionMat_Sym_Private(fn,As,vs,m,PETSC_TRUE);
    759:   MatDenseRestoreArray(A,&As);
    760:   VecRestoreArray(v,&vs);
    761:   return(0);
    762: }

    764: PetscErrorCode FNEvaluateFunctionMatVec_Private(FN fn,Mat A,Vec v,PetscBool sync)
    765: {
    767:   PetscBool      set,flg,symm=PETSC_FALSE;
    768:   PetscInt       m,n;
    769:   Mat            M;
    770:   PetscMPIInt    size,rank;
    771:   PetscScalar    *pv;

    774:   /* check symmetry of A */
    775:   MatIsHermitianKnown(A,&set,&flg);
    776:   symm = set? flg: PETSC_FALSE;

    778:   /* evaluate matrix function */
    779:   MPI_Comm_size(PetscObjectComm((PetscObject)fn),&size);
    780:   MPI_Comm_rank(PetscObjectComm((PetscObject)fn),&rank);
    781:   if (size==1 || fn->pmode==FN_PARALLEL_REDUNDANT || (fn->pmode==FN_PARALLEL_SYNCHRONIZED && !rank)) {
    782:     PetscFPTrapPush(PETSC_FP_TRAP_OFF);
    783:     if (symm && !fn->method) {  /* prefer diagonalization */
    784:       PetscInfo(fn,"Computing matrix function via diagonalization\n");
    785:       FNEvaluateFunctionMatVec_Sym_Default(fn,A,v);
    786:     } else {
    787:       /* scale argument */
    788:       if (fn->alpha!=(PetscScalar)1.0) {
    789:         FN_AllocateWorkMat(fn,A,&M);
    790:         MatScale(M,fn->alpha);
    791:       } else M = A;
    792:       if (fn->ops->evaluatefunctionmatvec[fn->method]) {
    793:         (*fn->ops->evaluatefunctionmatvec[fn->method])(fn,M,v);
    794:       } else {
    795:         FNEvaluateFunctionMatVec_Default(fn,M,v);
    796:       }
    797:       if (fn->alpha!=(PetscScalar)1.0) {
    798:         FN_FreeWorkMat(fn,&M);
    799:       }
    800:       /* scale result */
    801:       VecScale(v,fn->beta);
    802:     }
    803:     PetscFPTrapPop();
    804:   }

    806:   /* synchronize */
    807:   if (size>1 && fn->pmode==FN_PARALLEL_SYNCHRONIZED && sync) {
    808:     MatGetSize(A,&m,&n);
    809:     VecGetArray(v,&pv);
    810:     MPI_Bcast(pv,n,MPIU_SCALAR,0,PetscObjectComm((PetscObject)fn));
    811:     VecRestoreArray(v,&pv);
    812:   }
    813:   return(0);
    814: }

    816: /*@
    817:    FNEvaluateFunctionMatVec - Computes the first column of the matrix f(A)
    818:    for a given matrix A.

    820:    Logically Collective on fn

    822:    Input Parameters:
    823: +  fn - the math function context
    824: -  A  - matrix on which the function must be evaluated

    826:    Output Parameter:
    827: .  v  - vector to hold the first column of f(A)

    829:    Notes:
    830:    This operation is similar to FNEvaluateFunctionMat() but returns only
    831:    the first column of f(A), hence saving computations in most cases.

    833:    Level: advanced

    835: .seealso: FNEvaluateFunction(), FNEvaluateFunctionMat(), FNSetMethod()
    836: @*/
    837: PetscErrorCode FNEvaluateFunctionMatVec(FN fn,Mat A,Vec v)
    838: {
    840:   PetscBool      match;
    841:   PetscInt       m,n;

    850:   PetscObjectTypeCompare((PetscObject)A,MATSEQDENSE,&match);
    851:   if (!match) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_SUP,"Mat A must be of type seqdense");
    852:   MatGetSize(A,&m,&n);
    853:   if (m!=n) SETERRQ2(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_SIZ,"Mat A is not square (has %D rows, %D cols)",m,n);
    854:   VecGetSize(v,&m);
    855:   if (m!=n) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_SIZ,"Matrix A and vector v must have the same size");
    856:   PetscLogEventBegin(FN_Evaluate,fn,0,0,0);
    857:   FNEvaluateFunctionMatVec_Private(fn,A,v,PETSC_TRUE);
    858:   PetscLogEventEnd(FN_Evaluate,fn,0,0,0);
    859:   return(0);
    860: }

    862: /*@
    863:    FNSetFromOptions - Sets FN options from the options database.

    865:    Collective on fn

    867:    Input Parameters:
    868: .  fn - the math function context

    870:    Notes:
    871:    To see all options, run your program with the -help option.

    873:    Level: beginner
    874: @*/
    875: PetscErrorCode FNSetFromOptions(FN fn)
    876: {
    878:   char           type[256];
    879:   PetscScalar    array[2];
    880:   PetscInt       k,meth;
    881:   PetscBool      flg;
    882:   FNParallelType pmode;

    886:   FNRegisterAll();
    887:   PetscObjectOptionsBegin((PetscObject)fn);
    888:     PetscOptionsFList("-fn_type","Math function type","FNSetType",FNList,(char*)(((PetscObject)fn)->type_name?((PetscObject)fn)->type_name:FNRATIONAL),type,sizeof(type),&flg);
    889:     if (flg) {
    890:       FNSetType(fn,type);
    891:     } else if (!((PetscObject)fn)->type_name) {
    892:       FNSetType(fn,FNRATIONAL);
    893:     }

    895:     k = 2;
    896:     array[0] = 0.0; array[1] = 0.0;
    897:     PetscOptionsScalarArray("-fn_scale","Scale factors (one or two scalar values separated with a comma without spaces)","FNSetScale",array,&k,&flg);
    898:     if (flg) {
    899:       if (k<2) array[1] = 1.0;
    900:       FNSetScale(fn,array[0],array[1]);
    901:     }

    903:     PetscOptionsInt("-fn_method","Method to be used for computing matrix functions","FNSetMethod",fn->method,&meth,&flg);
    904:     if (flg) { FNSetMethod(fn,meth); }

    906:     PetscOptionsEnum("-fn_parallel","Operation mode in parallel runs","FNSetParallel",FNParallelTypes,(PetscEnum)fn->pmode,(PetscEnum*)&pmode,&flg);
    907:     if (flg) { FNSetParallel(fn,pmode); }

    909:     if (fn->ops->setfromoptions) {
    910:       (*fn->ops->setfromoptions)(PetscOptionsObject,fn);
    911:     }
    912:     PetscObjectProcessOptionsHandlers(PetscOptionsObject,(PetscObject)fn);
    913:   PetscOptionsEnd();
    914:   return(0);
    915: }

    917: /*@C
    918:    FNView - Prints the FN data structure.

    920:    Collective on fn

    922:    Input Parameters:
    923: +  fn - the math function context
    924: -  viewer - optional visualization context

    926:    Note:
    927:    The available visualization contexts include
    928: +     PETSC_VIEWER_STDOUT_SELF - standard output (default)
    929: -     PETSC_VIEWER_STDOUT_WORLD - synchronized standard
    930:          output where only the first processor opens
    931:          the file.  All other processors send their
    932:          data to the first processor to print.

    934:    The user can open an alternative visualization context with
    935:    PetscViewerASCIIOpen() - output to a specified file.

    937:    Level: beginner
    938: @*/
    939: PetscErrorCode FNView(FN fn,PetscViewer viewer)
    940: {
    941:   PetscBool      isascii;
    943:   PetscMPIInt    size;

    947:   if (!viewer) {
    948:     PetscViewerASCIIGetStdout(PetscObjectComm((PetscObject)fn),&viewer);
    949:   }
    952:   PetscObjectTypeCompare((PetscObject)viewer,PETSCVIEWERASCII,&isascii);
    953:   if (isascii) {
    954:     PetscObjectPrintClassNamePrefixType((PetscObject)fn,viewer);
    955:     MPI_Comm_size(PetscObjectComm((PetscObject)fn),&size);
    956:     if (size>1) {
    957:       PetscViewerASCIIPrintf(viewer,"  parallel operation mode: %s\n",FNParallelTypes[fn->pmode]);
    958:     }
    959:     if (fn->ops->view) {
    960:       PetscViewerASCIIPushTab(viewer);
    961:       (*fn->ops->view)(fn,viewer);
    962:       PetscViewerASCIIPopTab(viewer);
    963:     }
    964:   }
    965:   return(0);
    966: }

    968: /*@C
    969:    FNViewFromOptions - View from options

    971:    Collective on FN

    973:    Input Parameters:
    974: +  fn   - the math function context
    975: .  obj  - optional object
    976: -  name - command line option

    978:    Level: intermediate

    980: .seealso: FNView(), FNCreate()
    981: @*/
    982: PetscErrorCode FNViewFromOptions(FN fn,PetscObject obj,const char name[])
    983: {

    988:   PetscObjectViewFromOptions((PetscObject)fn,obj,name);
    989:   return(0);
    990: }

    992: /*@
    993:    FNDuplicate - Duplicates a math function, copying all parameters, possibly with a
    994:    different communicator.

    996:    Collective on fn

    998:    Input Parameters:
    999: +  fn   - the math function context
    1000: -  comm - MPI communicator

    1002:    Output Parameter:
    1003: .  newfn - location to put the new FN context

    1005:    Note:
    1006:    In order to use the same MPI communicator as in the original object,
    1007:    use PetscObjectComm((PetscObject)fn).

    1009:    Level: developer

    1011: .seealso: FNCreate()
    1012: @*/
    1013: PetscErrorCode FNDuplicate(FN fn,MPI_Comm comm,FN *newfn)
    1014: {
    1016:   FNType         type;
    1017:   PetscScalar    alpha,beta;
    1018:   PetscInt       meth;
    1019:   FNParallelType ptype;

    1025:   FNCreate(comm,newfn);
    1026:   FNGetType(fn,&type);
    1027:   FNSetType(*newfn,type);
    1028:   FNGetScale(fn,&alpha,&beta);
    1029:   FNSetScale(*newfn,alpha,beta);
    1030:   FNGetMethod(fn,&meth);
    1031:   FNSetMethod(*newfn,meth);
    1032:   FNGetParallel(fn,&ptype);
    1033:   FNSetParallel(*newfn,ptype);
    1034:   if (fn->ops->duplicate) {
    1035:     (*fn->ops->duplicate)(fn,comm,newfn);
    1036:   }
    1037:   return(0);
    1038: }

    1040: /*@
    1041:    FNDestroy - Destroys FN context that was created with FNCreate().

    1043:    Collective on fn

    1045:    Input Parameter:
    1046: .  fn - the math function context

    1048:    Level: beginner

    1050: .seealso: FNCreate()
    1051: @*/
    1052: PetscErrorCode FNDestroy(FN *fn)
    1053: {
    1055:   PetscInt       i;

    1058:   if (!*fn) return(0);
    1060:   if (--((PetscObject)(*fn))->refct > 0) { *fn = 0; return(0); }
    1061:   if ((*fn)->ops->destroy) { (*(*fn)->ops->destroy)(*fn); }
    1062:   for (i=0;i<(*fn)->nw;i++) {
    1063:     MatDestroy(&(*fn)->W[i]);
    1064:   }
    1065:   PetscHeaderDestroy(fn);
    1066:   return(0);
    1067: }

    1069: /*@C
    1070:    FNRegister - Adds a mathematical function to the FN package.

    1072:    Not collective

    1074:    Input Parameters:
    1075: +  name - name of a new user-defined FN
    1076: -  function - routine to create context

    1078:    Notes:
    1079:    FNRegister() may be called multiple times to add several user-defined functions.

    1081:    Level: advanced

    1083: .seealso: FNRegisterAll()
    1084: @*/
    1085: PetscErrorCode FNRegister(const char *name,PetscErrorCode (*function)(FN))
    1086: {

    1090:   FNInitializePackage();
    1091:   PetscFunctionListAdd(&FNList,name,function);
    1092:   return(0);
    1093: }