Date: 2015-09-03T15:03:43+00:00

Actual source code: dsnep.c
slepc-3.6.1 2015-09-03
Report Typos and Errors

      1: /*
      2:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      3:    SLEPc - Scalable Library for Eigenvalue Problem Computations
      4:    Copyright (c) 2002-2015, 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:   PetscTryMethod(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:   PetscTryMethod(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: }