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

Actual source code: dsghiep.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: */
     21: #include <slepc-private/dsimpl.h>      /*I "slepcds.h" I*/
     22: #include <slepcblaslapack.h>

     26: PetscErrorCode DSAllocate_GHIEP(DS ds,PetscInt ld)
     27: {

     31:   DSAllocateMat_Private(ds,DS_MAT_A);
     32:   DSAllocateMat_Private(ds,DS_MAT_B);
     33:   DSAllocateMat_Private(ds,DS_MAT_Q);
     34:   DSAllocateMatReal_Private(ds,DS_MAT_T);
     35:   DSAllocateMatReal_Private(ds,DS_MAT_D);
     36:   PetscFree(ds->perm);
     37:   PetscMalloc(ld*sizeof(PetscInt),&ds->perm);
     38:   PetscLogObjectMemory(ds,ld*sizeof(PetscInt));
     39:   return(0);
     40: }

     44: PetscErrorCode DSSwitchFormat_GHIEP(DS ds,PetscBool tocompact)
     45: {
     47:   PetscReal      *T,*S;
     48:   PetscScalar    *A,*B;
     49:   PetscInt       i,n,ld;

     52:   A = ds->mat[DS_MAT_A];
     53:   B = ds->mat[DS_MAT_B];
     54:   T = ds->rmat[DS_MAT_T];
     55:   S = ds->rmat[DS_MAT_D];
     56:   n = ds->n;
     57:   ld = ds->ld;
     58:   if (tocompact) { /* switch from dense (arrow) to compact storage */
     59:     PetscMemzero(T,3*ld*sizeof(PetscReal));
     60:     PetscMemzero(S,ld*sizeof(PetscReal));
     61:     for (i=0;i<n-1;i++) {
     62:       T[i] = PetscRealPart(A[i+i*ld]);
     63:       T[ld+i] = PetscRealPart(A[i+1+i*ld]);
     64:       S[i] = PetscRealPart(B[i+i*ld]);
     65:     }
     66:     T[n-1] = PetscRealPart(A[n-1+(n-1)*ld]);
     67:     S[n-1] = PetscRealPart(B[n-1+(n-1)*ld]);
     68:     for (i=ds->l;i< ds->k;i++) T[2*ld+i] = PetscRealPart(A[ds->k+i*ld]);
     69:   } else { /* switch from compact (arrow) to dense storage */
     70:     PetscMemzero(A,ld*ld*sizeof(PetscScalar));
     71:     PetscMemzero(B,ld*ld*sizeof(PetscScalar));
     72:     for (i=0;i<n-1;i++) {
     73:       A[i+i*ld] = T[i];
     74:       A[i+1+i*ld] = T[ld+i];
     75:       A[i+(i+1)*ld] = T[ld+i];
     76:       B[i+i*ld] = S[i];
     77:     }
     78:     A[n-1+(n-1)*ld] = T[n-1];
     79:     B[n-1+(n-1)*ld] = S[n-1];
     80:     for (i=ds->l;i<ds->k;i++) {
     81:       A[ds->k+i*ld] = T[2*ld+i];
     82:       A[i+ds->k*ld] = T[2*ld+i];
     83:     }
     84:   }
     85:   return(0);
     86: }

     90: PetscErrorCode DSView_GHIEP(DS ds,PetscViewer viewer)
     91: {
     92:   PetscErrorCode    ierr;
     93:   PetscViewerFormat format;
     94:   PetscInt          i,j;
     95:   PetscReal         value;
     96:   const char        *methodname[] = {
     97:                      "HR method",
     98:                      "QR + Inverse Iteration",
     99:                      "QR",
    100:                      "DQDS + Inverse Iteration "
    101:   };
    102:   const int         nmeth=sizeof(methodname)/sizeof(methodname[0]);

    105:   PetscViewerGetFormat(viewer,&format);
    106:   if (format == PETSC_VIEWER_ASCII_INFO || format == PETSC_VIEWER_ASCII_INFO_DETAIL) {
    107:     if (ds->method>=nmeth) {
    108:       PetscViewerASCIIPrintf(viewer,"solving the problem with: INVALID METHOD\n");
    109:     } else {
    110:       PetscViewerASCIIPrintf(viewer,"solving the problem with: %s\n",methodname[ds->method]);
    111:     }
    112:     return(0);
    113:   }
    114:   if (ds->compact) {
    115:     PetscViewerASCIIUseTabs(viewer,PETSC_FALSE);
    116:     if (format == PETSC_VIEWER_ASCII_MATLAB) {
    117:       PetscViewerASCIIPrintf(viewer,"%% Size = %D %D\n",ds->n,ds->n);
    118:       PetscViewerASCIIPrintf(viewer,"zzz = zeros(%D,3);\n",3*ds->n);
    119:       PetscViewerASCIIPrintf(viewer,"zzz = [\n");
    120:       for (i=0;i<ds->n;i++) {
    121:         PetscViewerASCIIPrintf(viewer,"%D %D  %18.16e\n",i+1,i+1,*(ds->rmat[DS_MAT_T]+i));
    122:       }
    123:       for (i=0;i<ds->n-1;i++) {
    124:         if (*(ds->rmat[DS_MAT_T]+ds->ld+i) !=0 && i!=ds->k-1) {
    125:           PetscViewerASCIIPrintf(viewer,"%D %D  %18.16e\n",i+2,i+1,*(ds->rmat[DS_MAT_T]+ds->ld+i));
    126:           PetscViewerASCIIPrintf(viewer,"%D %D  %18.16e\n",i+1,i+2,*(ds->rmat[DS_MAT_T]+ds->ld+i));
    127:         }
    128:       }
    129:       for (i = ds->l;i<ds->k;i++) {
    130:         PetscViewerASCIIPrintf(viewer,"%D %D  %18.16e\n",ds->k+1,i+1,*(ds->rmat[DS_MAT_T]+2*ds->ld+i));
    131:           PetscViewerASCIIPrintf(viewer,"%D %D  %18.16e\n",i+1,ds->k+1,*(ds->rmat[DS_MAT_T]+2*ds->ld+i));
    132:       }
    133:       PetscViewerASCIIPrintf(viewer,"];\n%s = spconvert(zzz);\n",DSMatName[DS_MAT_A]);

    135:       PetscViewerASCIIPrintf(viewer,"%% Size = %D %D\n",ds->n,ds->n);
    136:       PetscViewerASCIIPrintf(viewer,"omega = zeros(%D,3);\n",3*ds->n);
    137:       PetscViewerASCIIPrintf(viewer,"omega = [\n");
    138:       for (i=0;i<ds->n;i++) {
    139:         PetscViewerASCIIPrintf(viewer,"%D %D  %18.16e\n",i+1,i+1,*(ds->rmat[DS_MAT_D]+i));
    140:       }
    141:       PetscViewerASCIIPrintf(viewer,"];\n%s = spconvert(omega);\n",DSMatName[DS_MAT_B]);

    143:     } else {
    144:       PetscViewerASCIIPrintf(viewer,"T\n");
    145:       for (i=0;i<ds->n;i++) {
    146:         for (j=0;j<ds->n;j++) {
    147:           if (i==j) value = *(ds->rmat[DS_MAT_T]+i);
    148:           else if (i==j+1 || j==i+1) value = *(ds->rmat[DS_MAT_T]+ds->ld+PetscMin(i,j));
    149:           else if ((i<ds->k && j==ds->k) || (i==ds->k && j<ds->k)) value = *(ds->rmat[DS_MAT_T]+2*ds->ld+PetscMin(i,j));
    150:           else value = 0.0;
    151:           PetscViewerASCIIPrintf(viewer," %18.16e ",value);
    152:         }
    153:         PetscViewerASCIIPrintf(viewer,"\n");
    154:       }
    155:       PetscViewerASCIIPrintf(viewer,"omega\n");
    156:       for (i=0;i<ds->n;i++) {
    157:         for (j=0;j<ds->n;j++) {
    158:           if (i==j) value = *(ds->rmat[DS_MAT_D]+i);
    159:           else value = 0.0;
    160:           PetscViewerASCIIPrintf(viewer," %18.16e ",value);
    161:         }
    162:         PetscViewerASCIIPrintf(viewer,"\n");
    163:       }
    164:     }
    165:     PetscViewerASCIIUseTabs(viewer,PETSC_TRUE);
    166:     PetscViewerFlush(viewer);
    167:   } else {
    168:     DSViewMat_Private(ds,viewer,DS_MAT_A);
    169:     DSViewMat_Private(ds,viewer,DS_MAT_B);
    170:   }
    171:   if (ds->state>DS_STATE_INTERMEDIATE) {
    172:     DSViewMat_Private(ds,viewer,DS_MAT_Q);
    173:   }
    174:   return(0);
    175: }

    179: PetscErrorCode DSVectors_GHIEP_Eigen_Some(DS ds,PetscInt *idx,PetscReal *rnorm)
    180: {
    182:   PetscReal      b[4],M[4],d1,d2,s1,s2,e;
    183:   PetscReal      scal1,scal2,wr1,wr2,wi,ep,norm;
    184:   PetscScalar    *Q,*X,Y[4],alpha,zeroS = 0.0;
    185:   PetscInt       k;
    186:   PetscBLASInt   two = 2,n_,ld,one=1;
    187: #if !defined(PETSC_USE_COMPLEX)
    188:   PetscBLASInt   four=4;
    189: #endif

    192:   X = ds->mat[DS_MAT_X];
    193:   Q = ds->mat[DS_MAT_Q];
    194:   k = *idx;
    195:   PetscBLASIntCast(ds->n,&n_);
    196:   PetscBLASIntCast(ds->ld,&ld);
    197:   if (k < ds->n-1) {
    198:     e = (ds->compact)?*(ds->rmat[DS_MAT_T]+ld+k):PetscRealPart(*(ds->mat[DS_MAT_A]+(k+1)+ld*k));
    199:   } else e = 0.0;
    200:   if (e == 0.0) {/* Real */
    201:     if (ds->state>=DS_STATE_CONDENSED) {
    202:       PetscMemcpy(X+k*ld,Q+k*ld,ld*sizeof(PetscScalar));
    203:     } else {
    204:       PetscMemzero(X+k*ds->ld,ds->ld*sizeof(PetscScalar));
    205:       X[k+k*ds->ld] = 1.0;
    206:     }
    207:     if (rnorm) {
    208:       *rnorm = PetscAbsScalar(X[ds->n-1+k*ld]);
    209:     }
    210:   } else { /* 2x2 block */
    211:     if (ds->compact) {
    212:       s1 = *(ds->rmat[DS_MAT_D]+k);
    213:       d1 = *(ds->rmat[DS_MAT_T]+k);
    214:       s2 = *(ds->rmat[DS_MAT_D]+k+1);
    215:       d2 = *(ds->rmat[DS_MAT_T]+k+1);
    216:     } else {
    217:       s1 = PetscRealPart(*(ds->mat[DS_MAT_B]+k*ld+k));
    218:       d1 = PetscRealPart(*(ds->mat[DS_MAT_A]+k+k*ld));
    219:       s2 = PetscRealPart(*(ds->mat[DS_MAT_B]+(k+1)*ld+k+1));
    220:       d2 = PetscRealPart(*(ds->mat[DS_MAT_A]+k+1+(k+1)*ld));
    221:     }
    222:     M[0] = d1; M[1] = e; M[2] = e; M[3]= d2;
    223:     b[0] = s1; b[1] = 0.0; b[2] = 0.0; b[3] = s2;
    224:     ep = LAPACKlamch_("S");
    225:     /* Compute eigenvalues of the block */
    226:     PetscStackCallBLAS("LAPACKlag2",LAPACKlag2_(M,&two,b,&two,&ep,&scal1,&scal2,&wr1,&wr2,&wi));
    227:     if (wi==0.0)  /* Real eigenvalues */
    228:       SETERRQ(PETSC_COMM_SELF,1,"Real block in DSVectors_GHIEP");
    229:     else { /* Complex eigenvalues */
    230:       if (scal1<ep) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_FP,"Nearly infinite eigenvalue");
    231:       wr1 /= scal1; wi /= scal1;
    232: #if !defined(PETSC_USE_COMPLEX)
    233:       if (SlepcAbs(s1*d1-wr1,wi)<SlepcAbs(s2*d2-wr1,wi)) {
    234:         Y[0] = wr1-s2*d2; Y[1] = s2*e; Y[2] = wi; Y[3] = 0.0;
    235:       } else {
    236:         Y[0] = s1*e; Y[1] = wr1-s1*d1; Y[2] = 0.0; Y[3] = wi;
    237:       }
    238:       norm = BLASnrm2_(&four,Y,&one);
    239:       norm = 1/norm;
    240:       if (ds->state >= DS_STATE_CONDENSED) {
    241:         alpha = norm;
    242:         PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&n_,&two,&two,&alpha,ds->mat[DS_MAT_Q]+k*ld,&ld,Y,&two,&zeroS,X+k*ld,&ld));
    243:         if (rnorm) *rnorm = SlepcAbsEigenvalue(X[ds->n-1+k*ld],X[ds->n-1+(k+1)*ld]);
    244:       } else {
    245:         PetscMemzero(X+k*ld,2*ld*sizeof(PetscScalar));
    246:         X[k*ld+k] = Y[0]*norm; X[k*ld+k+1] = Y[1]*norm;
    247:         X[(k+1)*ld+k] = Y[2]*norm; X[(k+1)*ld+k+1] = Y[3]*norm;
    248:       }
    249: #else
    250:       if (SlepcAbs(s1*d1-wr1,wi)<SlepcAbs(s2*d2-wr1,wi)) {
    251:         Y[0] = wr1-s2*d2+PETSC_i*wi; Y[1] = s2*e;
    252:       } else {
    253:         Y[0] = s1*e; Y[1] = wr1-s1*d1+PETSC_i*wi;
    254:       }
    255:       norm = BLASnrm2_(&two,Y,&one);
    256:       norm = 1/norm;
    257:       if (ds->state >= DS_STATE_CONDENSED) {
    258:         alpha = norm;
    259:         PetscStackCallBLAS("BLASgemv",BLASgemv_("N",&n_,&two,&alpha,ds->mat[DS_MAT_Q]+k*ld,&ld,Y,&one,&zeroS,X+k*ld,&one));
    260:         if (rnorm) *rnorm = PetscAbsScalar(X[ds->n-1+k*ld]);
    261:       } else {
    262:         PetscMemzero(X+k*ld,2*ld*sizeof(PetscScalar));
    263:         X[k*ld+k] = Y[0]*norm; X[k*ld+k+1] = Y[1]*norm;
    264:       }
    265:       X[(k+1)*ld+k] = PetscConj(X[k*ld+k]); X[(k+1)*ld+k+1] = PetscConj(X[k*ld+k+1]);
    266: #endif
    267:       (*idx)++;
    268:     }
    269:   }
    270:   return(0);
    271: }

    275: PetscErrorCode DSVectors_GHIEP(DS ds,DSMatType mat,PetscInt *k,PetscReal *rnorm)
    276: {
    277:   PetscInt       i;
    278:   PetscReal      e;

    282:   switch (mat) {
    283:     case DS_MAT_X:
    284:       if (k) {
    285:         DSVectors_GHIEP_Eigen_Some(ds,k,rnorm);
    286:       } else {
    287:         for (i=0; i<ds->n; i++) {
    288:           e = (ds->compact)?*(ds->rmat[DS_MAT_T]+ds->ld+i):PetscRealPart(*(ds->mat[DS_MAT_A]+(i+1)+ds->ld*i));
    289:           if (e == 0.0) {/* real */
    290:             if (ds->state >= DS_STATE_CONDENSED) {
    291:               PetscMemcpy(ds->mat[mat]+i*ds->ld,ds->mat[DS_MAT_Q]+i*ds->ld,ds->ld*sizeof(PetscScalar));
    292:             } else {
    293:               PetscMemzero(ds->mat[mat]+i*ds->ld,ds->ld*sizeof(PetscScalar));
    294:               *(ds->mat[mat]+i+i*ds->ld) = 1.0;
    295:             }
    296:           } else {
    297:             DSVectors_GHIEP_Eigen_Some(ds,&i,rnorm);
    298:           }
    299:         }
    300:       }
    301:       break;
    302:     case DS_MAT_Y:
    303:     case DS_MAT_U:
    304:     case DS_MAT_VT:
    305:       SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Not implemented yet");
    306:       break;
    307:     default:
    308:       SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid mat parameter");
    309:   }
    310:   return(0);
    311: }

    315: /*
    316:   Extract the eigenvalues contained in the block-diagonal of the indefinite problem.
    317:   Only the index range n0..n1 is processed.
    318: */
    319: PetscErrorCode DSGHIEPComplexEigs(DS ds,PetscInt n0,PetscInt n1,PetscScalar *wr,PetscScalar *wi)
    320: {
    321:   PetscInt     k,ld;
    322:   PetscBLASInt two=2;
    323:   PetscScalar  *A,*B;
    324:   PetscReal    *D,*T;
    325:   PetscReal    b[4],M[4],d1,d2,s1,s2,e;
    326:   PetscReal    scal1,scal2,ep,wr1,wr2,wi1;

    329:   ld = ds->ld;
    330:   A = ds->mat[DS_MAT_A];
    331:   B = ds->mat[DS_MAT_B];
    332:   D = ds->rmat[DS_MAT_D];
    333:   T = ds->rmat[DS_MAT_T];
    334:   for (k=n0;k<n1;k++) {
    335:     if (k < n1-1) {
    336:       e = (ds->compact)?T[ld+k]:PetscRealPart(A[(k+1)+ld*k]);
    337:     } else {
    338:       e = 0.0;
    339:     }
    340:     if (e==0.0) {
    341:       /* real eigenvalue */
    342:       wr[k] = (ds->compact)?T[k]/D[k]:A[k+k*ld]/B[k+k*ld];
    343: #if !defined(PETSC_USE_COMPLEX)
    344:       wi[k] = 0.0 ;
    345: #endif
    346:     } else {
    347:       /* diagonal block */
    348:       if (ds->compact) {
    349:         s1 = D[k];
    350:         d1 = T[k];
    351:         s2 = D[k+1];
    352:         d2 = T[k+1];
    353:       } else {
    354:         s1 = PetscRealPart(B[k*ld+k]);
    355:         d1 = PetscRealPart(A[k+k*ld]);
    356:         s2 = PetscRealPart(B[(k+1)*ld+k+1]);
    357:         d2 = PetscRealPart(A[k+1+(k+1)*ld]);
    358:       }
    359:       M[0] = d1; M[1] = e; M[2] = e; M[3]= d2;
    360:       b[0] = s1; b[1] = 0.0; b[2] = 0.0; b[3] = s2;
    361:       ep = LAPACKlamch_("S");
    362:       /* Compute eigenvalues of the block */
    363:       PetscStackCallBLAS("LAPACKlag2",LAPACKlag2_(M,&two,b,&two,&ep,&scal1,&scal2,&wr1,&wr2,&wi1));
    364:       if (scal1<ep) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_FP,"Nearly infinite eigenvalue");
    365:       wr[k] = wr1/scal1;
    366:       if (wi1==0.0) { /* Real eigenvalues */
    367:         if (scal2<ep) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_FP,"Nearly infinite eigenvalue");
    368:         wr[k+1] = wr2/scal2;
    369: #if !defined(PETSC_USE_COMPLEX)
    370:         wi[k] = 0.0;
    371:         wi[k+1] = 0.0;
    372: #endif
    373:       } else { /* Complex eigenvalues */
    374: #if !defined(PETSC_USE_COMPLEX)
    375:         wr[k+1] = wr[k];
    376:         wi[k] = wi1/scal1;
    377:         wi[k+1] = -wi[k];
    378: #else
    379:         wr[k] += PETSC_i*wi1/scal1;
    380:         wr[k+1] = PetscConj(wr[k]);
    381: #endif
    382:       }
    383:       k++;
    384:     }
    385:   }
    386: #if defined(PETSC_USE_COMPLEX)
    387:   if (wi) {
    388:     for (k=n0;k<n1;k++) wi[k] = 0.0;
    389:   }
    390: #endif
    391:   return(0);
    392: }

    396: PetscErrorCode DSSort_GHIEP(DS ds,PetscScalar *wr,PetscScalar *wi,PetscScalar *rr,PetscScalar *ri,PetscInt *k)
    397: {
    399:   PetscInt       n,i,*perm;
    400:   PetscReal      *d,*e,*s;

    403: #if !defined(PETSC_USE_COMPLEX)
    405: #endif
    406:   n = ds->n;
    407:   d = ds->rmat[DS_MAT_T];
    408:   e = d + ds->ld;
    409:   s = ds->rmat[DS_MAT_D];
    410:   DSAllocateWork_Private(ds,ds->ld,ds->ld,0);
    411:   perm = ds->perm;
    412:   if (!rr) {
    413:     rr = wr;
    414:     ri = wi;
    415:   }
    416:   DSSortEigenvalues_Private(ds,rr,ri,perm,PETSC_TRUE);
    417:   if (!ds->compact) { DSSwitchFormat_GHIEP(ds,PETSC_TRUE); }
    418:   PetscMemcpy(ds->work,wr,n*sizeof(PetscScalar));
    419:   for (i=ds->l;i<n;i++) {
    420:     wr[i] = *(ds->work + perm[i]);
    421:   }
    422: #if !defined(PETSC_USE_COMPLEX)
    423:   PetscMemcpy(ds->work,wi,n*sizeof(PetscScalar));
    424:   for (i=ds->l;i<n;i++) {
    425:     wi[i] = *(ds->work + perm[i]);
    426:   }
    427: #endif
    428:   PetscMemcpy(ds->rwork,s,n*sizeof(PetscReal));
    429:   for (i=ds->l;i<n;i++) {
    430:     s[i] = *(ds->rwork+perm[i]);
    431:   }
    432:   PetscMemcpy(ds->rwork,d,n*sizeof(PetscReal));
    433:   for (i=ds->l;i<n;i++) {
    434:     d[i] = *(ds->rwork  + perm[i]);
    435:   }
    436:   PetscMemcpy(ds->rwork,e,(n-1)*sizeof(PetscReal));
    437:   PetscMemzero(e+ds->l,(n-1-ds->l)*sizeof(PetscScalar));
    438:   for (i=ds->l;i<n-1;i++) {
    439:     if (perm[i]<n-1) e[i] = *(ds->rwork + perm[i]);
    440:   }
    441:   if (!ds->compact) { DSSwitchFormat_GHIEP(ds,PETSC_FALSE); }
    442:   DSPermuteColumns_Private(ds,ds->l,n,DS_MAT_Q,perm);
    443:   return(0);
    444: }

    449: /*
    450:   Get eigenvectors with inverse iteration.
    451:   The system matrix is in Hessenberg form.
    452: */
    453: PetscErrorCode DSGHIEPInverseIteration(DS ds,PetscScalar *wr,PetscScalar *wi)
    454: {
    455: #if defined(PETSC_MISSING_LAPACK_HSEIN)
    457:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"HSEIN - Lapack routine is unavailable");
    458: #else
    460:   PetscInt       i,off;
    461:   PetscBLASInt   *select,*infoC,ld,n1,mout,info;
    462:   PetscScalar    *A,*B,*H,*X;
    463:   PetscReal      *s,*d,*e;

    466:   PetscBLASIntCast(ds->ld,&ld);
    467:   PetscBLASIntCast(ds->n-ds->l,&n1);
    468:   DSAllocateWork_Private(ds,ld*ld+2*ld,ld,2*ld);
    469:   DSAllocateMat_Private(ds,DS_MAT_W);
    470:   A = ds->mat[DS_MAT_A];
    471:   B = ds->mat[DS_MAT_B];
    472:   H = ds->mat[DS_MAT_W];
    473:   s = ds->rmat[DS_MAT_D];
    474:   d = ds->rmat[DS_MAT_T];
    475:   e = d + ld;
    476:   select = ds->iwork;
    477:   infoC = ds->iwork + ld;
    478:   off = ds->l+ds->l*ld;
    479:   if (ds->compact) {
    480:     H[off] = d[ds->l]*s[ds->l];
    481:     H[off+ld] = e[ds->l]*s[ds->l];
    482:     for (i=ds->l+1;i<ds->n-1;i++) {
    483:       H[i+(i-1)*ld] = e[i-1]*s[i];
    484:       H[i+i*ld] = d[i]*s[i];
    485:       H[i+(i+1)*ld] = e[i]*s[i];
    486:     }
    487:     H[ds->n-1+(ds->n-2)*ld] = e[ds->n-2]*s[ds->n-1];
    488:     H[ds->n-1+(ds->n-1)*ld] = d[ds->n-1]*s[ds->n-1];
    489:   } else {
    490:     s[ds->l] = PetscRealPart(B[off]);
    491:     H[off] = A[off]*s[ds->l];
    492:     H[off+ld] = A[off+ld]*s[ds->l];
    493:     for (i=ds->l+1;i<ds->n-1;i++) {
    494:       s[i] = PetscRealPart(B[i+i*ld]);
    495:       H[i+(i-1)*ld] = A[i+(i-1)*ld]*s[i];
    496:       H[i+i*ld]     = A[i+i*ld]*s[i];
    497:       H[i+(i+1)*ld] = A[i+(i+1)*ld]*s[i];
    498:     }
    499:     s[ds->n-1] = PetscRealPart(B[ds->n-1+(ds->n-1)*ld]);
    500:     H[ds->n-1+(ds->n-2)*ld] = A[ds->n-1+(ds->n-2)*ld]*s[ds->n-1];
    501:     H[ds->n-1+(ds->n-1)*ld] = A[ds->n-1+(ds->n-1)*ld]*s[ds->n-1];
    502:   }
    503:   DSAllocateMat_Private(ds,DS_MAT_X);
    504:   X = ds->mat[DS_MAT_X];
    505:   for (i=0;i<n1;i++)select[i]=1;
    506: #if !defined(PETSC_USE_COMPLEX)
    507:   PetscStackCallBLAS("LAPACKhsein",LAPACKhsein_("R","N","N",select,&n1,H+off,&ld,wr+ds->l,wi+ds->l,NULL,&ld,X+off,&ld,&n1,&mout,ds->work,NULL,infoC,&info));
    508: #else
    509:   PetscStackCallBLAS("LAPACKhsein",LAPACKhsein_("R","N","N",select,&n1,H+off,&ld,wr+ds->l,NULL,&ld,X+off,&ld,&n1,&mout,ds->work,ds->rwork,NULL,infoC,&info));
    510: #endif
    511:   if (info<0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in hsein routine %d",-i);
    512:   if (info>0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Convergence error in hsein routine %d",i);
    513:   DSGHIEPOrthogEigenv(ds,DS_MAT_X,wr,wi,PETSC_TRUE);
    514:   return(0);
    515: #endif
    516: }

    521: /*
    522:    Undo 2x2 blocks that have real eigenvalues.
    523: */
    524: PetscErrorCode DSGHIEPRealBlocks(DS ds)
    525: {
    527:   PetscInt       i;
    528:   PetscReal      e,d1,d2,s1,s2,ss1,ss2,t,dd,ss;
    529:   PetscReal      maxy,ep,scal1,scal2,snorm;
    530:   PetscReal      *T,*D,b[4],M[4],wr1,wr2,wi;
    531:   PetscScalar    *A,*B,Y[4],oneS = 1.0,zeroS = 0.0;
    532:   PetscBLASInt   m,two=2,ld;
    533:   PetscBool      isreal;

    536:   PetscBLASIntCast(ds->ld,&ld);
    537:   PetscBLASIntCast(ds->n-ds->l,&m);
    538:   A = ds->mat[DS_MAT_A];
    539:   B = ds->mat[DS_MAT_B];
    540:   T = ds->rmat[DS_MAT_T];
    541:   D = ds->rmat[DS_MAT_D];
    542:   DSAllocateWork_Private(ds,2*m,0,0);
    543:   for (i=ds->l;i<ds->n-1;i++) {
    544:     e = (ds->compact)?T[ld+i]:PetscRealPart(A[(i+1)+ld*i]);
    545:     if (e != 0.0) { /* 2x2 block */
    546:       if (ds->compact) {
    547:         s1 = D[i];
    548:         d1 = T[i];
    549:         s2 = D[i+1];
    550:         d2 = T[i+1];
    551:       } else {
    552:         s1 = PetscRealPart(B[i*ld+i]);
    553:         d1 = PetscRealPart(A[i*ld+i]);
    554:         s2 = PetscRealPart(B[(i+1)*ld+i+1]);
    555:         d2 = PetscRealPart(A[(i+1)*ld+i+1]);
    556:       }
    557:       isreal = PETSC_FALSE;
    558:       if (s1==s2) { /* apply a Jacobi rotation to compute the eigendecomposition */
    559:         dd = d1-d2;
    560:         if (2*PetscAbsReal(e) <= dd) {
    561:           t = 2*e/dd;
    562:           t = t/(1 + PetscSqrtReal(1+t*t));
    563:         } else {
    564:           t = dd/(2*e);
    565:           ss = (t>=0)?1.0:-1.0;
    566:           t = ss/(PetscAbsReal(t)+PetscSqrtReal(1+t*t));
    567:         }
    568:         Y[0] = 1/PetscSqrtReal(1 + t*t); Y[3] = Y[0]; /* c */
    569:         Y[1] = Y[0]*t; Y[2] = -Y[1]; /* s */
    570:         wr1 = d1+t*e;
    571:         wr2 = d2-t*e;
    572:         ss1 = s1; ss2 = s2;
    573:         isreal = PETSC_TRUE;
    574:       } else {
    575:         ss1 = 1.0; ss2 = 1.0,
    576:         M[0] = d1; M[1] = e; M[2] = e; M[3]= d2;
    577:         b[0] = s1; b[1] = 0.0; b[2] = 0.0; b[3] = s2;
    578:         ep = LAPACKlamch_("S");
    579:         /* Compute eigenvalues of the block */
    580:         PetscStackCallBLAS("LAPACKlag2",LAPACKlag2_(M,&two,b,&two,&ep,&scal1,&scal2,&wr1,&wr2,&wi));
    581:         if (wi==0.0) { /* Real eigenvalues */
    582:           isreal = PETSC_TRUE;
    583:           if (scal1<ep||scal2<ep) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_FP,"Nearly infinite eigenvalue");
    584:           wr1 /= scal1; wr2 /= scal2;
    585:           if (PetscAbsReal(s1*d1-wr1)<PetscAbsReal(s2*d2-wr1)) {
    586:             Y[0] = wr1-s2*d2;
    587:             Y[1] = s2*e;
    588:           } else {
    589:             Y[0] = s1*e;
    590:             Y[1] = wr1-s1*d1;
    591:           }
    592:           /* normalize with a signature*/
    593:           maxy = PetscMax(PetscAbsScalar(Y[0]),PetscAbsScalar(Y[1]));
    594:           scal1 = PetscRealPart(Y[0])/maxy; scal2 = PetscRealPart(Y[1])/maxy;
    595:           snorm = scal1*scal1*s1 + scal2*scal2*s2;
    596:           if (snorm<0) { ss1 = -1.0; snorm = -snorm; }
    597:           snorm = maxy*PetscSqrtReal(snorm); Y[0] = Y[0]/snorm; Y[1] = Y[1]/snorm;
    598:           if (PetscAbsReal(s1*d1-wr2)<PetscAbsReal(s2*d2-wr2)) {
    599:             Y[2] = wr2-s2*d2;
    600:             Y[3] = s2*e;
    601:           } else {
    602:             Y[2] = s1*e;
    603:             Y[3] = wr2-s1*d1;
    604:           }
    605:           maxy = PetscMax(PetscAbsScalar(Y[2]),PetscAbsScalar(Y[3]));
    606:           scal1 = PetscRealPart(Y[2])/maxy; scal2 = PetscRealPart(Y[3])/maxy;
    607:           snorm = scal1*scal1*s1 + scal2*scal2*s2;
    608:           if (snorm<0) { ss2 = -1.0; snorm = -snorm; }
    609:           snorm = maxy*PetscSqrtReal(snorm);Y[2] = Y[2]/snorm; Y[3] = Y[3]/snorm;
    610:         }
    611:         wr1 *= ss1; wr2 *= ss2;
    612:       }
    613:       if (isreal) {
    614:         if (ds->compact) {
    615:           D[i] = ss1;;
    616:           T[i] = wr1;
    617:           D[i+1] = ss2;
    618:           T[i+1] = wr2;
    619:           T[ld+i] = 0.0;
    620:         } else {
    621:           B[i*ld+i] = ss1;
    622:           A[i*ld+i] = wr1;
    623:           B[(i+1)*ld+i+1] = ss2;
    624:           A[(i+1)*ld+i+1] = wr2;
    625:           A[(i+1)+ld*i] = 0.0;
    626:           A[i+ld*(i+1)] = 0.0;
    627:         }
    628:         PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&m,&two,&two,&oneS,ds->mat[DS_MAT_Q]+ds->l+i*ld,&ld,Y,&two,&zeroS,ds->work,&m));
    629:         PetscMemcpy(ds->mat[DS_MAT_Q]+ds->l+i*ld,ds->work,m*sizeof(PetscScalar));
    630:         PetscMemcpy(ds->mat[DS_MAT_Q]+ds->l+(i+1)*ld,ds->work+m,m*sizeof(PetscScalar));
    631:       }
    632:       i++;
    633:     }
    634:   }
    635:   return(0);
    636: }

    640: PetscErrorCode DSSolve_GHIEP_QR_II(DS ds,PetscScalar *wr,PetscScalar *wi)
    641: {
    642: #if defined(PETSC_MISSING_LAPACK_HSEQR)
    644:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"HSEQR - Lapack routine is unavailable");
    645: #else
    647:   PetscInt       i,off;
    648:   PetscBLASInt   n1,ld,one,info,lwork;
    649:   PetscScalar    *H,*A,*B,*Q;
    650:   PetscReal      *d,*e,*s;

    653: #if !defined(PETSC_USE_COMPLEX)
    655: #endif
    656:   one = 1;
    657:   PetscBLASIntCast(ds->n-ds->l,&n1);
    658:   PetscBLASIntCast(ds->ld,&ld);
    659:   off = ds->l + ds->l*ld;
    660:   A = ds->mat[DS_MAT_A];
    661:   B = ds->mat[DS_MAT_B];
    662:   Q = ds->mat[DS_MAT_Q];
    663:   d = ds->rmat[DS_MAT_T];
    664:   e = ds->rmat[DS_MAT_T] + ld;
    665:   s = ds->rmat[DS_MAT_D];
    666:   DSAllocateWork_Private(ds,ld*ld,2*ld,ld*2);
    667:   lwork = ld*ld;

    669:   /* Quick return if possible */
    670:   if (n1 == 1) {
    671:     *(Q+off) = 1;
    672:     if (!ds->compact) {
    673:       d[ds->l] = PetscRealPart(A[off]);
    674:       s[ds->l] = PetscRealPart(B[off]);
    675:     }
    676:     wr[ds->l] = d[ds->l]/s[ds->l];
    677:     if (wi) wi[ds->l] = 0.0;
    678:     return(0);
    679:   }
    680:   /* Reduce to pseudotriadiagonal form */
    681:   DSIntermediate_GHIEP(ds);

    683:   /* Compute Eigenvalues (QR)*/
    684:   DSAllocateMat_Private(ds,DS_MAT_W);
    685:   H = ds->mat[DS_MAT_W];
    686:   if (ds->compact) {
    687:     H[off] = d[ds->l]*s[ds->l];
    688:     H[off+ld] = e[ds->l]*s[ds->l];
    689:     for (i=ds->l+1;i<ds->n-1;i++) {
    690:       H[i+(i-1)*ld] = e[i-1]*s[i];
    691:       H[i+i*ld]     = d[i]*s[i];
    692:       H[i+(i+1)*ld] = e[i]*s[i];
    693:     }
    694:     H[ds->n-1+(ds->n-2)*ld] = e[ds->n-2]*s[ds->n-1];
    695:     H[ds->n-1+(ds->n-1)*ld] = d[ds->n-1]*s[ds->n-1];
    696:   } else {
    697:     s[ds->l] = PetscRealPart(B[off]);
    698:     H[off] = A[off]*s[ds->l];
    699:     H[off+ld] = A[off+ld]*s[ds->l];
    700:     for (i=ds->l+1;i<ds->n-1;i++) {
    701:       s[i] = PetscRealPart(B[i+i*ld]);
    702:       H[i+(i-1)*ld] = A[i+(i-1)*ld]*s[i];
    703:       H[i+i*ld]     = A[i+i*ld]*s[i];
    704:       H[i+(i+1)*ld] = A[i+(i+1)*ld]*s[i];
    705:     }
    706:     s[ds->n-1] = PetscRealPart(B[ds->n-1+(ds->n-1)*ld]);
    707:     H[ds->n-1+(ds->n-2)*ld] = A[ds->n-1+(ds->n-2)*ld]*s[ds->n-1];
    708:     H[ds->n-1+(ds->n-1)*ld] = A[ds->n-1+(ds->n-1)*ld]*s[ds->n-1];
    709:   }

    711: #if !defined(PETSC_USE_COMPLEX)
    712:   PetscStackCallBLAS("LAPACKhseqr",LAPACKhseqr_("E","N",&n1,&one,&n1,H+off,&ld,wr+ds->l,wi+ds->l,NULL,&ld,ds->work,&lwork,&info));
    713: #else
    714:   PetscStackCallBLAS("LAPACKhseqr",LAPACKhseqr_("E","N",&n1,&one,&n1,H+off,&ld,wr+ds->l,NULL,&ld,ds->work,&lwork,&info));
    715: #endif
    716:   if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xHSEQR %d",&info);

    718:   /* Compute Eigenvectors with Inverse Iteration */
    719:   DSGHIEPInverseIteration(ds,wr,wi);

    721:   /* Recover eigenvalues from diagonal */
    722:   DSGHIEPComplexEigs(ds,0,ds->l,wr,wi);
    723: #if defined(PETSC_USE_COMPLEX)
    724:   if (wi) {
    725:     for (i=ds->l;i<ds->n;i++) wi[i] = 0.0;
    726:   }
    727: #endif
    728:   return(0);
    729: #endif
    730: }

    734: PetscErrorCode DSSolve_GHIEP_QR(DS ds,PetscScalar *wr,PetscScalar *wi)
    735: {
    736: #if defined(SLEPC_MISSING_LAPACK_GEHRD) || defined(SLEPC_MISSING_LAPACK_ORGHR) || defined(PETSC_MISSING_LAPACK_HSEQR)
    738:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GEHRD/ORGHR/HSEQR - Lapack routines are unavailable");
    739: #else
    741:   PetscInt       i,off;
    742:   PetscBLASInt   n1,ld,one,info,lwork,mout;
    743:   PetscScalar    *H,*A,*B,*Q,*X;
    744:   PetscReal      *d,*e,*s;

    747: #if !defined(PETSC_USE_COMPLEX)
    749: #endif
    750:   one = 1;
    751:   PetscBLASIntCast(ds->n-ds->l,&n1);
    752:   PetscBLASIntCast(ds->ld,&ld);
    753:   off = ds->l + ds->l*ld;
    754:   A = ds->mat[DS_MAT_A];
    755:   B = ds->mat[DS_MAT_B];
    756:   Q = ds->mat[DS_MAT_Q];
    757:   d = ds->rmat[DS_MAT_T];
    758:   e = ds->rmat[DS_MAT_T] + ld;
    759:   s = ds->rmat[DS_MAT_D];
    760:   DSAllocateWork_Private(ds,ld+ld*ld,2*ld,ld*2);
    761:   lwork = ld*ld;

    763:   /* Quick return if possible */
    764:   if (n1 == 1) {
    765:     *(Q+off) = 1;
    766:     if (!ds->compact) {
    767:       d[ds->l] = PetscRealPart(A[off]);
    768:       s[ds->l] = PetscRealPart(B[off]);
    769:     }
    770:     wr[ds->l] = d[ds->l]/s[ds->l];
    771:     if (wi) wi[ds->l] = 0.0;
    772:     return(0);
    773:   }
    774:   /* Reduce to pseudotriadiagonal form */
    775:   DSIntermediate_GHIEP(ds);

    777:   /* form standard problem in H */
    778:   DSAllocateMat_Private(ds,DS_MAT_W);
    779:   H = ds->mat[DS_MAT_W];
    780:   if (ds->compact) {
    781:     H[off] = d[ds->l]*s[ds->l];
    782:     H[off+ld] = e[ds->l]*s[ds->l];
    783:     for (i=ds->l+1;i<ds->n-1;i++) {
    784:       H[i+(i-1)*ld] = e[i-1]*s[i];
    785:       H[i+i*ld]     = d[i]*s[i];
    786:       H[i+(i+1)*ld] = e[i]*s[i];
    787:     }
    788:     H[ds->n-1+(ds->n-2)*ld] = e[ds->n-2]*s[ds->n-1];
    789:     H[ds->n-1+(ds->n-1)*ld] = d[ds->n-1]*s[ds->n-1];
    790:   } else {
    791:     s[ds->l] = PetscRealPart(B[off]);
    792:     H[off] = A[off]*s[ds->l];
    793:     H[off+ld] = A[off+ld]*s[ds->l];
    794:     for (i=ds->l+1;i<ds->n-1;i++) {
    795:       s[i] = PetscRealPart(B[i+i*ld]);
    796:       H[i+(i-1)*ld] = A[i+(i-1)*ld]*s[i];
    797:       H[i+i*ld]     = A[i+i*ld]*s[i];
    798:       H[i+(i+1)*ld] = A[i+(i+1)*ld]*s[i];
    799:     }
    800:     s[ds->n-1] = PetscRealPart(B[ds->n-1+(ds->n-1)*ld]);
    801:     H[ds->n-1+(ds->n-2)*ld] = A[ds->n-1+(ds->n-2)*ld]*s[ds->n-1];
    802:     H[ds->n-1+(ds->n-1)*ld] = A[ds->n-1+(ds->n-1)*ld]*s[ds->n-1];
    803:   }
    804:   /* Compute the real Schur form */
    805:   DSAllocateMat_Private(ds,DS_MAT_X);
    806:   X = ds->mat[DS_MAT_X];
    807: #if !defined(PETSC_USE_COMPLEX)
    808:   PetscStackCallBLAS("LAPACKhseqr",LAPACKhseqr_("S","I",&n1,&one,&n1,H+off,&ld,wr+ds->l,wi+ds->l,X+off,&ld,ds->work,&lwork,&info));
    809: #else
    810:   PetscStackCallBLAS("LAPACKhseqr",LAPACKhseqr_("S","I",&n1,&one,&n1,H+off,&ld,wr+ds->l,X+off,&ld,ds->work,&lwork,&info));
    811: #endif
    812:   if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xHSEQR %d",&info);

    814:   /* Compute eigenvectors */
    815: #if !defined(PETSC_USE_COMPLEX)
    816:   PetscStackCallBLAS("LAPACKtrevc",LAPACKtrevc_("R","B",NULL,&n1,H+off,&ld,NULL,&ld,X+off,&ld,&n1,&mout,ds->work,&info));
    817: #else
    818:   PetscStackCallBLAS("LAPACKtrevc",LAPACKtrevc_("R","B",NULL,&n1,H+off,&ld,NULL,&ld,X+off,&ld,&n1,&mout,ds->work,ds->rwork,&info));
    819: #endif
    820:   if (info) SETERRQ1(PetscObjectComm((PetscObject)ds),PETSC_ERR_LIB,"Error in Lapack xTREVC %i",&info);

    822:   /* Compute real s-orthonormal basis */
    823:   DSGHIEPOrthogEigenv(ds,DS_MAT_X,wr,wi,PETSC_TRUE);

    825:   /* Recover eigenvalues from diagonal */
    826:   DSGHIEPComplexEigs(ds,0,ds->l,wr,wi);
    827: #if defined(PETSC_USE_COMPLEX)
    828:   if (wi) {
    829:     for (i=ds->l;i<ds->n;i++) wi[i] = 0.0;
    830:   }
    831: #endif
    832:   return(0);
    833: #endif
    834: }

    838: PetscErrorCode DSNormalize_GHIEP(DS ds,DSMatType mat,PetscInt col)
    839: {
    841:   PetscInt       i,i0,i1;
    842:   PetscBLASInt   ld,n,one = 1;
    843:   PetscScalar    *A = ds->mat[DS_MAT_A],norm,*x;
    844: #if !defined(PETSC_USE_COMPLEX)
    845:   PetscScalar    norm0;
    846: #endif

    849:   switch (mat) {
    850:     case DS_MAT_X:
    851:     case DS_MAT_Y:
    852:     case DS_MAT_Q:
    853:       /* Supported matrices */
    854:       break;
    855:     case DS_MAT_U:
    856:     case DS_MAT_VT:
    857:       SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Not implemented yet");
    858:       break;
    859:     default:
    860:       SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid mat parameter");
    861:   }

    863:   PetscBLASIntCast(ds->n,&n);
    864:   PetscBLASIntCast(ds->ld,&ld);
    865:   DSGetArray(ds,mat,&x);
    866:   if (col < 0) {
    867:     i0 = 0; i1 = ds->n;
    868:   } else if (col>0 && A[ds->ld*(col-1)+col] != 0.0) {
    869:     i0 = col-1; i1 = col+1;
    870:   } else {
    871:     i0 = col; i1 = col+1;
    872:   }
    873:   for (i=i0; i<i1; i++) {
    874: #if !defined(PETSC_USE_COMPLEX)
    875:     if (i<n-1 && A[ds->ld*i+i+1] != 0.0) {
    876:       norm = BLASnrm2_(&n,&x[ld*i],&one);
    877:       norm0 = BLASnrm2_(&n,&x[ld*(i+1)],&one);
    878:       norm = 1.0/SlepcAbsEigenvalue(norm,norm0);
    879:       PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*i],&one));
    880:       PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*(i+1)],&one));
    881:       i++;
    882:     } else
    883: #endif
    884:     {
    885:       norm = BLASnrm2_(&n,&x[ld*i],&one);
    886:       norm = 1.0/norm;
    887:       PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*i],&one));
    888:      }
    889:   }
    890:   return(0);
    891: }

    895: PETSC_EXTERN PetscErrorCode DSCreate_GHIEP(DS ds)
    896: {
    898:   ds->ops->allocate      = DSAllocate_GHIEP;
    899:   ds->ops->view          = DSView_GHIEP;
    900:   ds->ops->vectors       = DSVectors_GHIEP;
    901:   ds->ops->solve[0]      = DSSolve_GHIEP_HZ;
    902:   ds->ops->solve[1]      = DSSolve_GHIEP_QR_II;
    903:   ds->ops->solve[2]      = DSSolve_GHIEP_QR;
    904:   ds->ops->solve[3]      = DSSolve_GHIEP_DQDS_II;
    905:   ds->ops->sort          = DSSort_GHIEP;
    906:   ds->ops->normalize     = DSNormalize_GHIEP;
    907:   return(0);
    908: }