Date: 2013-09-02T10:09:34+00:00

Actual source code: dsgnhep.c

      1: /*
      2:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      3:    SLEPc - Scalable Library for Eigenvalue Problem Computations
      4:    Copyright (c) 2002-2013, 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: /*
     26:   1) Patterns of A and B
     27:       DS_STATE_RAW:       DS_STATE_INTERM/CONDENSED
     28:        0       n-1              0       n-1
     29:       -------------            -------------
     30:     0 |* * * * * *|          0 |* * * * * *|
     31:       |* * * * * *|            |  * * * * *|
     32:       |* * * * * *|            |    * * * *|
     33:       |* * * * * *|            |    * * * *|
     34:       |* * * * * *|            |        * *|
     35:   n-1 |* * * * * *|        n-1 |          *|
     36:       -------------            -------------

     38:   2) Moreover, P and Q are assumed to be the identity in DS_STATE_INTERMEDIATE.
     39: */

     42: static PetscErrorCode CleanDenseSchur(PetscInt n,PetscInt k,PetscScalar *S,PetscInt ldS,PetscScalar *T,PetscInt ldT,PetscScalar *X,PetscInt ldX,PetscScalar *Y,PetscInt ldY,PetscBool doProd);

     46: PetscErrorCode DSAllocate_GNHEP(DS ds,PetscInt ld)
     47: {

     51:   DSAllocateMat_Private(ds,DS_MAT_A);
     52:   DSAllocateMat_Private(ds,DS_MAT_B);
     53:   DSAllocateMat_Private(ds,DS_MAT_Z);
     54:   DSAllocateMat_Private(ds,DS_MAT_Q);
     55:   PetscFree(ds->perm);
     56:   PetscMalloc(ld*sizeof(PetscInt),&ds->perm);
     57:   PetscLogObjectMemory(ds,ld*sizeof(PetscInt));
     58:   return(0);
     59: }

     63: PetscErrorCode DSView_GNHEP(DS ds,PetscViewer viewer)
     64: {

     68:   DSViewMat_Private(ds,viewer,DS_MAT_A);
     69:   DSViewMat_Private(ds,viewer,DS_MAT_B);
     70:   if (ds->state>DS_STATE_INTERMEDIATE) {
     71:     DSViewMat_Private(ds,viewer,DS_MAT_Z);
     72:     DSViewMat_Private(ds,viewer,DS_MAT_Q);
     73:   }
     74:   if (ds->mat[DS_MAT_X]) {
     75:     DSViewMat_Private(ds,viewer,DS_MAT_X);
     76:   }
     77:   if (ds->mat[DS_MAT_Y]) {
     78:     DSViewMat_Private(ds,viewer,DS_MAT_Y);
     79:   }
     80:   return(0);
     81: }

     85: PetscErrorCode DSVectors_GNHEP_Eigen_Some(DS ds,PetscInt *k,PetscBool left)
     86: {
     87: #if defined(SLEPC_MISSING_LAPACK_TGEVC)
     89:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"TGEVC - Lapack routine is unavailable");
     90: #else
     92:   PetscInt       i;
     93:   PetscBLASInt   n,ld,mout,info,*select,mm;
     94:   PetscScalar    *X,*Y,*A = ds->mat[DS_MAT_A],*B = ds->mat[DS_MAT_B],fone=1.0,fzero=0.0;
     95:   PetscBool      iscomplex = PETSC_FALSE;
     96:   const char     *side;

     99:   PetscBLASIntCast(ds->n,&n);
    100:   PetscBLASIntCast(ds->ld,&ld);
    101:   if (left) {
    102:     X = NULL;
    103:     Y = &ds->mat[DS_MAT_Y][ld*(*k)];
    104:     side = "L";
    105:   } else {
    106:     X = &ds->mat[DS_MAT_X][ld*(*k)];
    107:     Y = NULL;
    108:     side = "R";
    109:   }
    110:   DSAllocateWork_Private(ds,0,0,ld);
    111:   select = ds->iwork;
    112:   for (i=0;i<n;i++) select[i] = 0;
    113:   select[*k] = 1;
    114:   if (ds->state <= DS_STATE_INTERMEDIATE) {
    115:     DSSetIdentity(ds,DS_MAT_Q);
    116:     DSSetIdentity(ds,DS_MAT_Z);
    117:   }
    118:   CleanDenseSchur(n,0,A,ld,B,ld,ds->mat[DS_MAT_Q],ld,ds->mat[DS_MAT_Z],ld,PETSC_TRUE);
    119:   if (ds->state < DS_STATE_CONDENSED) {
    120:     DSSetState(ds,DS_STATE_CONDENSED);
    121:   }
    122: #if defined(PETSC_USE_COMPLEX)
    123:   mm = 1;
    124:   DSAllocateWork_Private(ds,2*ld,2*ld,0);
    125:   PetscStackCallBLAS("LAPACKtgevc",LAPACKtgevc_(side,"S",select,&n,A,&ld,B,&ld,Y,&ld,X,&ld,&mm,&mout,ds->work,ds->rwork,&info));
    126: #else
    127:   if ((*k)<n-1 && (A[ld*(*k)+(*k)+1] != 0.0 || B[ld*(*k)+(*k)+1] != 0.0)) iscomplex = PETSC_TRUE;
    128:   mm = iscomplex ? 2 : 1;
    129:   DSAllocateWork_Private(ds,6*ld,0,0);
    130:   PetscStackCallBLAS("LAPACKtgevc",LAPACKtgevc_(side,"S",select,&n,A,&ld,B,&ld,Y,&ld,X,&ld,&mm,&mout,ds->work,&info));
    131: #endif
    132:   if (info) SETERRQ1(PetscObjectComm((PetscObject)ds),PETSC_ERR_LIB,"Error in Lapack xTGEVC %i",info);
    133:   if (select[(*k)] == 0 || mout != mm) SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_SUP,"Unsupported the computation of the second vector in a complex pair");
    134:   /* Backtransform: (X/Y) <- (Q/Z) * (X/Y) */
    135:   PetscMemcpy(ds->work,left?Y:X,mm*ld*sizeof(PetscScalar));
    136:   PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&n,&mm,&n,&fone,ds->mat[left?DS_MAT_Z:DS_MAT_Q],&ld,ds->work,&ld,&fzero,left?Y:X,&ld));
    137:   /* Update k to the last vector index in the conjugate pair */
    138:   if (iscomplex) (*k)++;
    139:   return(0);
    140: #endif
    141: }

    145: PetscErrorCode DSVectors_GNHEP_Eigen_All(DS ds,PetscBool left)
    146: {
    147: #if defined(SLEPC_MISSING_LAPACK_TGEVC)
    149:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"TGEVC - Lapack routine is unavailable");
    150: #else
    152:   PetscBLASInt   n,ld,mout,info;
    153:   PetscScalar    *X,*Y,*A = ds->mat[DS_MAT_A],*B = ds->mat[DS_MAT_B];
    154:   const char     *side,*back;

    157:   PetscBLASIntCast(ds->n,&n);
    158:   PetscBLASIntCast(ds->ld,&ld);
    159:   if (left) {
    160:     X = NULL;
    161:     Y = ds->mat[DS_MAT_Y];
    162:     side = "L";
    163:   } else {
    164:     X = ds->mat[DS_MAT_X];
    165:     Y = NULL;
    166:     side = "R";
    167:   }
    168:   if (ds->state <= DS_STATE_INTERMEDIATE) {
    169:     DSSetIdentity(ds,DS_MAT_Q);
    170:     DSSetIdentity(ds,DS_MAT_Z);
    171:   }
    172:   CleanDenseSchur(n,0,A,ld,B,ld,ds->mat[DS_MAT_Q],ld,ds->mat[DS_MAT_Z],ld,PETSC_TRUE);
    173:   if (ds->state>=DS_STATE_CONDENSED) {
    174:     /* DSSolve() has been called, backtransform with matrix Q */
    175:     back = "B";
    176:     PetscMemcpy(left?Y:X,ds->mat[left?DS_MAT_Z:DS_MAT_Q],ld*ld*sizeof(PetscScalar));
    177:   } else {
    178:     back = "A";
    179:     DSSetState(ds,DS_STATE_CONDENSED);
    180:   }
    181: #if defined(PETSC_USE_COMPLEX)
    182:   DSAllocateWork_Private(ds,2*ld,2*ld,0);
    183:   PetscStackCallBLAS("LAPACKtgevc",LAPACKtgevc_(side,back,NULL,&n,A,&ld,B,&ld,Y,&ld,X,&ld,&n,&mout,ds->work,ds->rwork,&info));
    184: #else
    185:   DSAllocateWork_Private(ds,6*ld,0,0);
    186:   PetscStackCallBLAS("LAPACKtgevc",LAPACKtgevc_(side,back,NULL,&n,A,&ld,B,&ld,Y,&ld,X,&ld,&n,&mout,ds->work,&info));
    187: #endif
    188:   if (info) SETERRQ1(PetscObjectComm((PetscObject)ds),PETSC_ERR_LIB,"Error in Lapack xTGEVC %i",info);
    189:   return(0);
    190: #endif
    191: }

    195: PetscErrorCode DSVectors_GNHEP(DS ds,DSMatType mat,PetscInt *k,PetscReal *rnorm)
    196: {

    200:   if (rnorm) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Not implemented yet");
    201:   switch (mat) {
    202:     case DS_MAT_X:
    203:     case DS_MAT_Y:
    204:       if (k) {
    205:         DSVectors_GNHEP_Eigen_Some(ds,k,mat == DS_MAT_Y?PETSC_TRUE:PETSC_FALSE);
    206:       } else {
    207:         DSVectors_GNHEP_Eigen_All(ds,mat == DS_MAT_Y?PETSC_TRUE:PETSC_FALSE);
    208:       }
    209:       break;
    210:     default:
    211:       SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid mat parameter");
    212:   }
    213:   return(0);
    214: }

    218: PetscErrorCode DSNormalize_GNHEP(DS ds,DSMatType mat,PetscInt col)
    219: {
    221:   PetscInt       i,i0,i1;
    222:   PetscBLASInt   ld,n,one = 1;
    223:   PetscScalar    *A = ds->mat[DS_MAT_A],*B = ds->mat[DS_MAT_B],norm,*x;
    224: #if !defined(PETSC_USE_COMPLEX)
    225:   PetscScalar    norm0;
    226: #endif

    229:   switch (mat) {
    230:     case DS_MAT_X:
    231:     case DS_MAT_Y:
    232:     case DS_MAT_Q:
    233:     case DS_MAT_Z:
    234:       /* Supported matrices */
    235:       break;
    236:     case DS_MAT_U:
    237:     case DS_MAT_VT:
    238:       SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Not implemented yet");
    239:       break;
    240:     default:
    241:       SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid mat parameter");
    242:   }

    244:   PetscBLASIntCast(ds->n,&n);
    245:   PetscBLASIntCast(ds->ld,&ld);
    246:   DSGetArray(ds,mat,&x);
    247:   if (col < 0) {
    248:     i0 = 0; i1 = ds->n;
    249:   } else if (col>0 && (A[ds->ld*(col-1)+col] != 0.0 || (B && B[ds->ld*(col-1)+col] != 0.0))) {
    250:     i0 = col-1; i1 = col+1;
    251:   } else {
    252:     i0 = col; i1 = col+1;
    253:   }
    254:   for (i=i0;i<i1;i++) {
    255: #if !defined(PETSC_USE_COMPLEX)
    256:     if (i<n-1 && (A[ds->ld*i+i+1] != 0.0 || (B && B[ds->ld*i+i+1] != 0.0))) {
    257:       norm = BLASnrm2_(&n,&x[ld*i],&one);
    258:       norm0 = BLASnrm2_(&n,&x[ld*(i+1)],&one);
    259:       norm = 1.0/SlepcAbsEigenvalue(norm,norm0);
    260:       PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*i],&one));
    261:       PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*(i+1)],&one));
    262:       i++;
    263:     } else
    264: #endif
    265:     {
    266:       norm = BLASnrm2_(&n,&x[ld*i],&one);
    267:       norm = 1.0/norm;
    268:       PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*i],&one));
    269:     }
    270:   }
    271:   return(0);
    272: }

    276: PetscErrorCode DSSort_GNHEP_Arbitrary(DS ds,PetscScalar *wr,PetscScalar *wi,PetscScalar *rr,PetscScalar *ri,PetscInt *k)
    277: {
    278: #if defined(SLEPC_MISSING_LAPACK_TGSEN)
    280:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"TGSEN - Lapack routine is unavailable");
    281: #else
    283:   PetscInt       i;
    284:   PetscBLASInt   info,n,ld,mout,lwork,liwork,*iwork,*selection,zero_=0,true_=1;
    285:   PetscScalar    *S = ds->mat[DS_MAT_A],*T = ds->mat[DS_MAT_B],*Q = ds->mat[DS_MAT_Q],*Z = ds->mat[DS_MAT_Z],*work,*beta;

    288:   if (!ds->comparison) return(0);
    289:   PetscBLASIntCast(ds->n,&n);
    290:   PetscBLASIntCast(ds->ld,&ld);
    291: #if !defined(PETSC_USE_COMPLEX)
    292:   lwork = 4*n+16;
    293: #else
    294:   lwork = 1;
    295: #endif
    296:   liwork = 1;
    297:   DSAllocateWork_Private(ds,lwork+2*n,0,liwork+n);
    298:   beta = ds->work;
    299:   work = ds->work + n;
    300:   lwork = ds->lwork - n;
    301:   selection = ds->iwork;
    302:   iwork = ds->iwork + n;
    303:   liwork = ds->liwork - n;
    304:   /* Compute the selected eigenvalue to be in the leading position */
    305:   DSSortEigenvalues_Private(ds,rr,ri,ds->perm,PETSC_FALSE);
    306:   PetscMemzero(selection,n*sizeof(PetscBLASInt));
    307:   for (i=0; i<*k; i++) selection[ds->perm[i]] = 1;
    308: #if !defined(PETSC_USE_COMPLEX)
    309:   PetscStackCallBLAS("LAPACKtgsen",LAPACKtgsen_(&zero_,&true_,&true_,selection,&n,S,&ld,T,&ld,wr,wi,beta,Z,&ld,Q,&ld,&mout,NULL,NULL,NULL,work,&lwork,iwork,&liwork,&info));
    310: #else
    311:   PetscStackCallBLAS("LAPACKtgsen",LAPACKtgsen_(&zero_,&true_,&true_,selection,&n,S,&ld,T,&ld,wr,beta,Z,&ld,Q,&ld,&mout,NULL,NULL,NULL,work,&lwork,iwork,&liwork,&info));
    312: #endif
    313:   if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xTGSEN %d",info);
    314:   *k = mout;
    315:   for (i=0;i<n;i++) {
    316:     if (beta[i]==0.0) wr[i] = (PetscRealPart(wr[i])>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
    317:     else wr[i] /= beta[i];
    318: #if !defined(PETSC_USE_COMPLEX)
    319:     if (beta[i]==0.0) wi[i] = (wi[i]>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
    320:     else wi[i] /= beta[i];
    321: #endif
    322:   }
    323:   return(0);
    324: #endif
    325: }

    329: PetscErrorCode DSSort_GNHEP_Total(DS ds,PetscScalar *wr,PetscScalar *wi)
    330: {
    331: #if defined(SLEPC_MISSING_LAPACK_TGEXC) || !defined(PETSC_USE_COMPLEX) && (defined(SLEPC_MISSING_LAPACK_LAMCH) || defined(SLEPC_MISSING_LAPACK_LAG2))
    333:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"TGEXC/LAMCH/LAG2 - Lapack routines are unavailable");
    334: #else
    336:   PetscScalar    re;
    337:   PetscInt       i,j,pos,result;
    338:   PetscBLASInt   ifst,ilst,info,n,ld,one=1;
    339:   PetscScalar    *S = ds->mat[DS_MAT_A],*T = ds->mat[DS_MAT_B],*Z = ds->mat[DS_MAT_Z],*Q = ds->mat[DS_MAT_Q];
    340: #if !defined(PETSC_USE_COMPLEX)
    341:   PetscBLASInt   lwork;
    342:   PetscScalar    *work,a,safmin,scale1,scale2,im;
    343: #endif

    346:   if (!ds->comparison) return(0);
    347:   PetscBLASIntCast(ds->n,&n);
    348:   PetscBLASIntCast(ds->ld,&ld);
    349: #if !defined(PETSC_USE_COMPLEX)
    350:   lwork = -1;
    351:   PetscStackCallBLAS("LAPACKtgexc",LAPACKtgexc_(&one,&one,&ld,NULL,&ld,NULL,&ld,NULL,&ld,NULL,&ld,&one,&one,&a,&lwork,&info));
    352:   safmin = LAPACKlamch_("S");
    353:   lwork = a;
    354:   DSAllocateWork_Private(ds,lwork,0,0);
    355:   work = ds->work;
    356: #endif
    357:   /* selection sort */
    358:   for (i=ds->l;i<n-1;i++) {
    359:     re = wr[i];
    360: #if !defined(PETSC_USE_COMPLEX)
    361:     im = wi[i];
    362: #endif
    363:     pos = 0;
    364:     j = i+1; /* j points to the next eigenvalue */
    365: #if !defined(PETSC_USE_COMPLEX)
    366:     if (im != 0) j=i+2;
    367: #endif
    368:     /* find minimum eigenvalue */
    369:     for (;j<n;j++) {
    370: #if !defined(PETSC_USE_COMPLEX)
    371:       (*ds->comparison)(re,im,wr[j],wi[j],&result,ds->comparisonctx);
    372: #else
    373:       (*ds->comparison)(re,0.0,wr[j],0.0,&result,ds->comparisonctx);
    374: #endif
    375:       if (result > 0) {
    376:         re = wr[j];
    377: #if !defined(PETSC_USE_COMPLEX)
    378:         im = wi[j];
    379: #endif
    380:         pos = j;
    381:       }
    382: #if !defined(PETSC_USE_COMPLEX)
    383:       if (wi[j] != 0) j++;
    384: #endif
    385:     }
    386:     if (pos) {
    387:       /* interchange blocks */
    388:       PetscBLASIntCast(pos+1,&ifst);
    389:       PetscBLASIntCast(i+1,&ilst);
    390: #if !defined(PETSC_USE_COMPLEX)
    391:       PetscStackCallBLAS("LAPACKtgexc",LAPACKtgexc_(&one,&one,&n,S,&ld,T,&ld,Z,&ld,Q,&ld,&ifst,&ilst,work,&lwork,&info));
    392: #else
    393:       PetscStackCallBLAS("LAPACKtgexc",LAPACKtgexc_(&one,&one,&n,S,&ld,T,&ld,Z,&ld,Q,&ld,&ifst,&ilst,&info));
    394: #endif
    395:       if (info) SETERRQ1(PetscObjectComm((PetscObject)ds),PETSC_ERR_LIB,"Error in Lapack xTGEXC %i",info);
    396:       /* recover original eigenvalues from T and S matrices */
    397:       for (j=i;j<n;j++) {
    398: #if !defined(PETSC_USE_COMPLEX)
    399:         if (j<n-1 && S[j*ld+j+1] != 0.0) {
    400:           /* complex conjugate eigenvalue */
    401:           PetscStackCallBLAS("LAPACKlag2",LAPACKlag2_(S+j*ld+j,&ld,T+j*ld+j,&ld,&safmin,&scale1,&scale2,&re,&a,&im));
    402:           wr[j] = re / scale1;
    403:           wi[j] = im / scale1;
    404:           wr[j+1] = a / scale2;
    405:           wi[j+1] = -wi[j];
    406:           j++;
    407:         } else
    408: #endif
    409:         {
    410:           if (T[j*ld+j] == 0.0) wr[j] = (PetscRealPart(S[j*ld+j])>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
    411:           else wr[j] = S[j*ld+j] / T[j*ld+j];
    412: #if !defined(PETSC_USE_COMPLEX)
    413:           wi[j] = 0.0;
    414: #endif
    415:         }
    416:       }
    417:     }
    418: #if !defined(PETSC_USE_COMPLEX)
    419:     if (wi[i] != 0.0) i++;
    420: #endif
    421:   }
    422:   return(0);
    423: #endif
    424: }

    428: PetscErrorCode DSSort_GNHEP(DS ds,PetscScalar *wr,PetscScalar *wi,PetscScalar *rr,PetscScalar *ri,PetscInt *k)
    429: {

    433:   if (!rr || wr == rr) {
    434:     DSSort_GNHEP_Total(ds,wr,wi);
    435:   } else {
    436:     DSSort_GNHEP_Arbitrary(ds,wr,wi,rr,ri,k);
    437:   }
    438:   return(0);
    439: }

    443: /*
    444:    Write zeros from the column k to n in the lower triangular part of the
    445:    matrices S and T, and inside 2-by-2 diagonal blocks of T in order to
    446:    make (S,T) a valid Schur decompositon.
    447: */
    448: static PetscErrorCode CleanDenseSchur(PetscInt n,PetscInt k,PetscScalar *S,PetscInt ldS,PetscScalar *T,PetscInt ldT,PetscScalar *X,PetscInt ldX,PetscScalar *Y,PetscInt ldY,PetscBool doProd)
    449: {
    450: #if defined(SLEPC_MISSING_LAPACK_LASV2)
    452:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"LASV2 - Lapack routine is unavailable");
    453: #else
    454:   PetscInt       i,j;
    455: #if defined(PETSC_USE_COMPLEX)
    456:   PetscScalar    s;
    457: #else
    459:   PetscBLASInt   ldS_,ldT_,n_i,n_i_2,one=1,n_,i_2,i_;
    460:   PetscScalar    b11,b22,sr,cr,sl,cl;
    461: #endif

    464:   if (!doProd && X) {
    465:     for (i=0;i<n;i++) for (j=0;j<n;j++) X[ldX*i+j] = 0.0;
    466:     for (i=0;i<n;i++) X[ldX*i+i] = 1.0;
    467:   }
    468:   if (!doProd && Y) {
    469:     for (i=0;i<n;i++) for (j=0;j<n;j++) Y[ldY*i+j] = 0.0;
    470:     for (i=0;i<n;i++) Y[ldX*i+i] = 1.0;
    471:   }

    473: #if defined(PETSC_USE_COMPLEX)
    474:   for (i=k; i<n; i++) {
    475:     /* Some functions need the diagonal elements in T be real */
    476:     if (T && PetscImaginaryPart(T[ldT*i+i]) != 0.0) {
    477:       s = PetscConj(T[ldT*i+i])/PetscAbsScalar(T[ldT*i+i]);
    478:       for (j=0;j<=i;j++) {
    479:         T[ldT*i+j] *= s;
    480:         S[ldS*i+j] *= s;
    481:       }
    482:       T[ldT*i+i] = PetscRealPart(T[ldT*i+i]);
    483:       if (X) for (j=0;j<n;j++) X[ldX*i+j] *= s;
    484:     }
    485:     j = i+1;
    486:     if (j<n) {
    487:       S[ldS*i+j] = 0.0;
    488:       if (T) T[ldT*i+j] = 0.0;
    489:     }
    490:   }
    491: #else
    492:   PetscBLASIntCast(ldS,&ldS_);
    493:   PetscBLASIntCast(ldT,&ldT_);
    494:   PetscBLASIntCast(n,&n_);
    495:   for (i=k;i<n-1;i++) {
    496:     if (S[ldS*i+i+1] != 0.0) {
    497:       /* Check if T(i+1,i) and T(i,i+1) are zero */
    498:       if (T[ldT*(i+1)+i] != 0.0 || T[ldT*i+i+1] != 0.0) {
    499:         /* Check if T(i+1,i) and T(i,i+1) are negligible */
    500:         if (PetscAbs(T[ldT*(i+1)+i])+PetscAbs(T[ldT*i+i+1]) < (PetscAbs(T[ldT*i+i])+PetscAbs(T[ldT*(i+1)+i+1]))*PETSC_MACHINE_EPSILON) {
    501:           T[ldT*i+i+1] = 0.0;
    502:           T[ldT*(i+1)+i] = 0.0;

    504:         } else {
    505:           /* If one of T(i+1,i) or T(i,i+1) is negligible, we make zero the other element */
    506:           if (PetscAbs(T[ldT*i+i+1]) < (PetscAbs(T[ldT*i+i])+PetscAbs(T[ldT*(i+1)+i+1])+PetscAbs(T[ldT*(i+1)+i]))*PETSC_MACHINE_EPSILON) {
    507:             PetscStackCallBLAS("LAPACKlasv2",LAPACKlasv2_(&T[ldT*i+i],&T[ldT*(i+1)+i],&T[ldT*(i+1)+i+1],&b22,&b11,&sl,&cl,&sr,&cr));
    508:           } else if (PetscAbs(T[ldT*(i+1)+i]) < (PetscAbs(T[ldT*i+i])+PetscAbs(T[ldT*(i+1)+i+1])+PetscAbs(T[ldT*i+i+1]))*PETSC_MACHINE_EPSILON) {
    509:             PetscStackCallBLAS("LAPACKlasv2",LAPACKlasv2_(&T[ldT*i+i],&T[ldT*i+i+1],&T[ldT*(i+1)+i+1],&b22,&b11,&sr,&cr,&sl,&cl));
    510:           } else {
    511:             SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Unsupported format. Call DSSolve before this function");
    512:           }
    513:           PetscBLASIntCast(n-i,&n_i);
    514:           n_i_2 = n_i - 2;
    515:           PetscBLASIntCast(i+2,&i_2);
    516:           PetscBLASIntCast(i,&i_);
    517:           if (b11 < 0.0) {
    518:             cr  = -cr;
    519:             sr  = -sr;
    520:             b11 = -b11;
    521:             b22 = -b22;
    522:           }
    523:           PetscStackCallBLAS("BLASrot",BLASrot_(&n_i,&S[ldS*i+i],&ldS_,&S[ldS*i+i+1],&ldS_,&cl,&sl));
    524:           PetscStackCallBLAS("BLASrot",BLASrot_(&i_2,&S[ldS*i],&one,&S[ldS*(i+1)],&one,&cr,&sr));
    525:           PetscStackCallBLAS("BLASrot",BLASrot_(&n_i_2,&T[ldT*(i+2)+i],&ldT_,&T[ldT*(i+2)+i+1],&ldT_,&cl,&sl));
    526:           PetscStackCallBLAS("BLASrot",BLASrot_(&i_,&T[ldT*i],&one,&T[ldT*(i+1)],&one,&cr,&sr));
    527:           if (X) PetscStackCallBLAS("BLASrot",BLASrot_(&n_,&X[ldX*i],&one,&X[ldX*(i+1)],&one,&cr,&sr));
    528:           if (Y) PetscStackCallBLAS("BLASrot",BLASrot_(&n_,&Y[ldY*i],&one,&Y[ldY*(i+1)],&one,&cl,&sl));
    529:           T[ldT*i+i] = b11;
    530:           T[ldT*i+i+1] = 0.0;
    531:           T[ldT*(i+1)+i] = 0.0;
    532:           T[ldT*(i+1)+i+1] = b22;
    533:         }
    534:       }
    535:     i++;
    536:     }
    537:   }
    538: #endif
    539:   return(0);
    540: #endif
    541: }

    545: PetscErrorCode DSSolve_GNHEP(DS ds,PetscScalar *wr,PetscScalar *wi)
    546: {
    547: #if defined(PETSC_MISSING_LAPACK_GGES)
    549:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GGES - Lapack routines are unavailable");
    550: #else
    552:   PetscScalar    *work,*beta,a;
    553:   PetscInt       i;
    554:   PetscBLASInt   lwork,info,n,ld,iaux;
    555:   PetscScalar    *A = ds->mat[DS_MAT_A],*B = ds->mat[DS_MAT_B],*Z = ds->mat[DS_MAT_Z],*Q = ds->mat[DS_MAT_Q];

    558: #if !defined(PETSC_USE_COMPLEX)
    560: #endif
    561:   PetscBLASIntCast(ds->n,&n);
    562:   PetscBLASIntCast(ds->ld,&ld);
    563:   lwork = -1;
    564: #if !defined(PETSC_USE_COMPLEX)
    565:   PetscStackCallBLAS("LAPACKgges",LAPACKgges_("V","V","N",NULL,&n,A,&ld,B,&ld,&iaux,wr,wi,NULL,Z,&ld,Q,&ld,&a,&lwork,NULL,&info));
    566:   lwork = (PetscBLASInt)a;
    567:   DSAllocateWork_Private(ds,lwork+ld,0,0);
    568:   beta = ds->work;
    569:   work = beta+ds->n;
    570:   PetscBLASIntCast(ds->lwork-ds->n,&lwork);
    571:   PetscStackCallBLAS("LAPACKgges",LAPACKgges_("V","V","N",NULL,&n,A,&ld,B,&ld,&iaux,wr,wi,beta,Z,&ld,Q,&ld,work,&lwork,NULL,&info));
    572: #else
    573:   PetscStackCallBLAS("LAPACKgges",LAPACKgges_("V","V","N",NULL,&n,A,&ld,B,&ld,&iaux,wr,NULL,Z,&ld,Q,&ld,&a,&lwork,NULL,NULL,&info));
    574:   lwork = (PetscBLASInt)PetscRealPart(a);
    575:   DSAllocateWork_Private(ds,lwork+ld,8*ld,0);
    576:   beta = ds->work;
    577:   work = beta+ds->n;
    578:   PetscBLASIntCast(ds->lwork-ds->n,&lwork);
    579:   PetscStackCallBLAS("LAPACKgges",LAPACKgges_("V","V","N",NULL,&n,A,&ld,B,&ld,&iaux,wr,beta,Z,&ld,Q,&ld,work,&lwork,ds->rwork,NULL,&info));
    580: #endif
    581:   if (info) SETERRQ1(PetscObjectComm((PetscObject)ds),PETSC_ERR_LIB,"Error in Lapack xGGES %i",info);
    582:   for (i=0;i<n;i++) {
    583:     if (beta[i]==0.0) wr[i] = (PetscRealPart(wr[i])>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
    584:     else wr[i] /= beta[i];
    585: #if !defined(PETSC_USE_COMPLEX)
    586:     if (beta[i]==0.0) wi[i] = (wi[i]>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
    587:     else wi[i] /= beta[i];
    588: #else
    589:     if (wi) wi[i] = 0.0;
    590: #endif
    591:   }
    592:   return(0);
    593: #endif
    594: }

    598: PETSC_EXTERN PetscErrorCode DSCreate_GNHEP(DS ds)
    599: {
    601:   ds->ops->allocate      = DSAllocate_GNHEP;
    602:   ds->ops->view          = DSView_GNHEP;
    603:   ds->ops->vectors       = DSVectors_GNHEP;
    604:   ds->ops->solve[0]      = DSSolve_GNHEP;
    605:   ds->ops->sort          = DSSort_GNHEP;
    606:   ds->ops->normalize     = DSNormalize_GNHEP;
    607:   return(0);
    608: }