Date: 2021-09-20T09:43:37+00:00

Actual source code: fnbasic.c
slepc-3.15.2 2021-09-20
Report Typos and Errors

      1: /*
      2:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      3:    SLEPc - Scalable Library for Eigenvalue Problem Computations
      4:    Copyright (c) 2002-2021, 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,const 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,adummy,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,&adummy,&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,&adummy,&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: {
    591:   PetscErrorCode    ierr;
    592:   PetscInt          m;
    593:   const PetscScalar *As;
    594:   PetscScalar       *Bs;

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

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

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

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

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

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

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

    662:    Logically Collective on fn

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

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

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

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

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

    685:    Level: advanced

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

    700:   if (B) {
    703:   } else inplace = PETSC_TRUE;
    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) {
    709:     n1 = n;
    710:     MatGetSize(B,&m,&n);
    711:     if (m!=n) SETERRQ2(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_SIZ,"Mat B is not square (has %D rows, %D cols)",m,n);
    712:     if (n1!=n) SETERRQ(PetscObjectComm((PetscObject)fn),PETSC_ERR_ARG_SIZ,"Matrices A and B must have the same dimension");
    713:   }

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

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

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

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

    755:   MatDenseGetArrayRead(A,&As);
    756:   VecGetArray(v,&vs);
    757:   MatGetSize(A,&m,NULL);
    758:   FNEvaluateFunctionMat_Sym_Private(fn,As,vs,m,PETSC_TRUE);
    759:   MatDenseRestoreArrayRead(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);CHKERRMPI(ierr);
    780:   MPI_Comm_rank(PetscObjectComm((PetscObject)fn),&rank);CHKERRMPI(ierr);
    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));CHKERRMPI(ierr);
    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:   PetscInt       m,n;

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

    860: /*@
    861:    FNSetFromOptions - Sets FN options from the options database.

    863:    Collective on fn

    865:    Input Parameters:
    866: .  fn - the math function context

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

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

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

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

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

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

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

    915: /*@C
    916:    FNView - Prints the FN data structure.

    918:    Collective on fn

    920:    Input Parameters:
    921: +  fn - the math function context
    922: -  viewer - optional visualization context

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

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

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

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

    966: /*@C
    967:    FNViewFromOptions - View from options

    969:    Collective on FN

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

    976:    Level: intermediate

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

    986:   PetscObjectViewFromOptions((PetscObject)fn,obj,name);
    987:   return(0);
    988: }

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

    994:    Collective on fn

    996:    Input Parameters:
    997: +  fn   - the math function context
    998: -  comm - MPI communicator

    1000:    Output Parameter:
    1001: .  newfn - location to put the new FN context

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

    1007:    Level: developer

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

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

    1038: /*@C
    1039:    FNDestroy - Destroys FN context that was created with FNCreate().

    1041:    Collective on fn

    1043:    Input Parameter:
    1044: .  fn - the math function context

    1046:    Level: beginner

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

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

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

    1070:    Not collective

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

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

    1079:    Level: advanced

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

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