Actual source code: dsghiep.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: */
 21: #include <slepc/private/dsimpl.h>
 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:   PetscMalloc1(ld,&ds->perm);
 38:   PetscLogObjectMemory((PetscObject)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:         if (*(ds->rmat[DS_MAT_T]+2*ds->ld+i)) {
131:           PetscViewerASCIIPrintf(viewer,"%D %D  %18.16e\n",ds->k+1,i+1,*(ds->rmat[DS_MAT_T]+2*ds->ld+i));
132:           PetscViewerASCIIPrintf(viewer,"%D %D  %18.16e\n",i+1,ds->k+1,*(ds->rmat[DS_MAT_T]+2*ds->ld+i));
133:         }
134:       }
135:       PetscViewerASCIIPrintf(viewer,"];\n%s = spconvert(zzz);\n",DSMatName[DS_MAT_A]);

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

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

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

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

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

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

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

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

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

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


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

463:   PetscBLASIntCast(ds->ld,&ld);
464:   PetscBLASIntCast(ds->n-ds->l,&n1);
465:   DSAllocateWork_Private(ds,ld*ld+2*ld,ld,2*ld);
466:   DSAllocateMat_Private(ds,DS_MAT_W);
467:   A = ds->mat[DS_MAT_A];
468:   B = ds->mat[DS_MAT_B];
469:   H = ds->mat[DS_MAT_W];
470:   s = ds->rmat[DS_MAT_D];
471:   d = ds->rmat[DS_MAT_T];
472:   e = d + ld;
473:   select = ds->iwork;
474:   infoC = ds->iwork + ld;
475:   off = ds->l+ds->l*ld;
476:   if (ds->compact) {
477:     H[off] = d[ds->l]*s[ds->l];
478:     H[off+ld] = e[ds->l]*s[ds->l];
479:     for (i=ds->l+1;i<ds->n-1;i++) {
480:       H[i+(i-1)*ld] = e[i-1]*s[i];
481:       H[i+i*ld] = d[i]*s[i];
482:       H[i+(i+1)*ld] = e[i]*s[i];
483:     }
484:     H[ds->n-1+(ds->n-2)*ld] = e[ds->n-2]*s[ds->n-1];
485:     H[ds->n-1+(ds->n-1)*ld] = d[ds->n-1]*s[ds->n-1];
486:   } else {
487:     s[ds->l] = PetscRealPart(B[off]);
488:     H[off] = A[off]*s[ds->l];
489:     H[off+ld] = A[off+ld]*s[ds->l];
490:     for (i=ds->l+1;i<ds->n-1;i++) {
491:       s[i] = PetscRealPart(B[i+i*ld]);
492:       H[i+(i-1)*ld] = A[i+(i-1)*ld]*s[i];
493:       H[i+i*ld]     = A[i+i*ld]*s[i];
494:       H[i+(i+1)*ld] = A[i+(i+1)*ld]*s[i];
495:     }
496:     s[ds->n-1] = PetscRealPart(B[ds->n-1+(ds->n-1)*ld]);
497:     H[ds->n-1+(ds->n-2)*ld] = A[ds->n-1+(ds->n-2)*ld]*s[ds->n-1];
498:     H[ds->n-1+(ds->n-1)*ld] = A[ds->n-1+(ds->n-1)*ld]*s[ds->n-1];
499:   }
500:   DSAllocateMat_Private(ds,DS_MAT_X);
501:   X = ds->mat[DS_MAT_X];
502:   for (i=0;i<n1;i++) select[i] = 1;
503: #if !defined(PETSC_USE_COMPLEX)
504:   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));
505: #else
506:   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));

508:   /* Separate real and imaginary part of complex eigenvectors */
509:   for (j=ds->l;j<ds->n;j++) {
510:     if (PetscAbsReal(PetscImaginaryPart(wr[j])) > PetscAbsScalar(wr[j])*PETSC_SQRT_MACHINE_EPSILON) {
511:       for (i=ds->l;i<ds->n;i++) {
512:         X[i+(j+1)*ds->ld] = PetscImaginaryPart(X[i+j*ds->ld]);
513:         X[i+j*ds->ld] = PetscRealPart(X[i+j*ds->ld]);
514:       }
515:       j++;
516:     }
517:   }
518: #endif
519:   if (info<0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in hsein routine %d",-i);
520:   if (info>0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Convergence error in hsein routine %d",i);
521:   DSGHIEPOrthogEigenv(ds,DS_MAT_X,wr,wi,PETSC_TRUE);
522:   return(0);
523: #endif
524: }


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

544:   PetscBLASIntCast(ds->ld,&ld);
545:   PetscBLASIntCast(ds->n-ds->l,&m);
546:   A = ds->mat[DS_MAT_A];
547:   B = ds->mat[DS_MAT_B];
548:   T = ds->rmat[DS_MAT_T];
549:   D = ds->rmat[DS_MAT_D];
550:   DSAllocateWork_Private(ds,2*m,0,0);
551:   for (i=ds->l;i<ds->n-1;i++) {
552:     e = (ds->compact)?T[ld+i]:PetscRealPart(A[(i+1)+ld*i]);
553:     if (e != 0.0) { /* 2x2 block */
554:       if (ds->compact) {
555:         s1 = D[i];
556:         d1 = T[i];
557:         s2 = D[i+1];
558:         d2 = T[i+1];
559:       } else {
560:         s1 = PetscRealPart(B[i*ld+i]);
561:         d1 = PetscRealPart(A[i*ld+i]);
562:         s2 = PetscRealPart(B[(i+1)*ld+i+1]);
563:         d2 = PetscRealPart(A[(i+1)*ld+i+1]);
564:       }
565:       isreal = PETSC_FALSE;
566:       if (s1==s2) { /* apply a Jacobi rotation to compute the eigendecomposition */
567:         dd = d1-d2;
568:         if (2*PetscAbsReal(e) <= dd) {
569:           t = 2*e/dd;
570:           t = t/(1 + PetscSqrtReal(1+t*t));
571:         } else {
572:           t = dd/(2*e);
573:           ss = (t>=0)?1.0:-1.0;
574:           t = ss/(PetscAbsReal(t)+PetscSqrtReal(1+t*t));
575:         }
576:         Y[0] = 1/PetscSqrtReal(1 + t*t); Y[3] = Y[0]; /* c */
577:         Y[1] = Y[0]*t; Y[2] = -Y[1]; /* s */
578:         wr1 = d1+t*e;
579:         wr2 = d2-t*e;
580:         ss1 = s1; ss2 = s2;
581:         isreal = PETSC_TRUE;
582:       } else {
583:         ss1 = 1.0; ss2 = 1.0,
584:         M[0] = d1; M[1] = e; M[2] = e; M[3]= d2;
585:         b[0] = s1; b[1] = 0.0; b[2] = 0.0; b[3] = s2;
586:         ep = LAPACKlamch_("S");

588:         /* Compute eigenvalues of the block */
589:         PetscStackCallBLAS("LAPACKlag2",LAPACKlag2_(M,&two,b,&two,&ep,&scal1,&scal2,&wr1,&wr2,&wi));
590:         if (wi==0.0) { /* Real eigenvalues */
591:           isreal = PETSC_TRUE;
592:           if (scal1<ep||scal2<ep) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_FP,"Nearly infinite eigenvalue");
593:           wr1 /= scal1; wr2 /= scal2;
594:           if (PetscAbsReal(s1*d1-wr1)<PetscAbsReal(s2*d2-wr1)) {
595:             Y[0] = wr1-s2*d2;
596:             Y[1] = s2*e;
597:           } else {
598:             Y[0] = s1*e;
599:             Y[1] = wr1-s1*d1;
600:           }
601:           /* normalize with a signature*/
602:           maxy = PetscMax(PetscAbsScalar(Y[0]),PetscAbsScalar(Y[1]));
603:           scal1 = PetscRealPart(Y[0])/maxy; scal2 = PetscRealPart(Y[1])/maxy;
604:           snorm = scal1*scal1*s1 + scal2*scal2*s2;
605:           if (snorm<0) { ss1 = -1.0; snorm = -snorm; }
606:           snorm = maxy*PetscSqrtReal(snorm); Y[0] = Y[0]/snorm; Y[1] = Y[1]/snorm;
607:           if (PetscAbsReal(s1*d1-wr2)<PetscAbsReal(s2*d2-wr2)) {
608:             Y[2] = wr2-s2*d2;
609:             Y[3] = s2*e;
610:           } else {
611:             Y[2] = s1*e;
612:             Y[3] = wr2-s1*d1;
613:           }
614:           maxy = PetscMax(PetscAbsScalar(Y[2]),PetscAbsScalar(Y[3]));
615:           scal1 = PetscRealPart(Y[2])/maxy; scal2 = PetscRealPart(Y[3])/maxy;
616:           snorm = scal1*scal1*s1 + scal2*scal2*s2;
617:           if (snorm<0) { ss2 = -1.0; snorm = -snorm; }
618:           snorm = maxy*PetscSqrtReal(snorm);Y[2] = Y[2]/snorm; Y[3] = Y[3]/snorm;
619:         }
620:         wr1 *= ss1; wr2 *= ss2;
621:       }
622:       if (isreal) {
623:         if (ds->compact) {
624:           D[i] = ss1;
625:           T[i] = wr1;
626:           D[i+1] = ss2;
627:           T[i+1] = wr2;
628:           T[ld+i] = 0.0;
629:         } else {
630:           B[i*ld+i] = ss1;
631:           A[i*ld+i] = wr1;
632:           B[(i+1)*ld+i+1] = ss2;
633:           A[(i+1)*ld+i+1] = wr2;
634:           A[(i+1)+ld*i] = 0.0;
635:           A[i+ld*(i+1)] = 0.0;
636:         }
637:         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));
638:         PetscMemcpy(ds->mat[DS_MAT_Q]+ds->l+i*ld,ds->work,m*sizeof(PetscScalar));
639:         PetscMemcpy(ds->mat[DS_MAT_Q]+ds->l+(i+1)*ld,ds->work+m,m*sizeof(PetscScalar));
640:       }
641:       i++;
642:     }
643:   }
644:   return(0);
645: }

649: PetscErrorCode DSSolve_GHIEP_QR_II(DS ds,PetscScalar *wr,PetscScalar *wi)
650: {
651: #if defined(PETSC_MISSING_LAPACK_HSEQR)
653:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"HSEQR - Lapack routine is unavailable");
654: #else
656:   PetscInt       i,off;
657:   PetscBLASInt   n1,ld,one,info,lwork;
658:   PetscScalar    *H,*A,*B,*Q;
659:   PetscReal      *d,*e,*s;
660: #if defined(PETSC_USE_COMPLEX)
661:   PetscInt       j;
662: #endif

665: #if !defined(PETSC_USE_COMPLEX)
667: #endif
668:   one = 1;
669:   PetscBLASIntCast(ds->n-ds->l,&n1);
670:   PetscBLASIntCast(ds->ld,&ld);
671:   off = ds->l + ds->l*ld;
672:   A = ds->mat[DS_MAT_A];
673:   B = ds->mat[DS_MAT_B];
674:   Q = ds->mat[DS_MAT_Q];
675:   d = ds->rmat[DS_MAT_T];
676:   e = ds->rmat[DS_MAT_T] + ld;
677:   s = ds->rmat[DS_MAT_D];
678:   DSAllocateWork_Private(ds,ld*ld,2*ld,ld*2);
679:   lwork = ld*ld;

681:   /* Quick return if possible */
682:   if (n1 == 1) {
683:     *(Q+off) = 1;
684:     if (!ds->compact) {
685:       d[ds->l] = PetscRealPart(A[off]);
686:       s[ds->l] = PetscRealPart(B[off]);
687:     }
688:     wr[ds->l] = d[ds->l]/s[ds->l];
689:     if (wi) wi[ds->l] = 0.0;
690:     return(0);
691:   }
692:   /* Reduce to pseudotriadiagonal form */
693:   DSIntermediate_GHIEP(ds);

695:   /* Compute Eigenvalues (QR)*/
696:   DSAllocateMat_Private(ds,DS_MAT_W);
697:   H = ds->mat[DS_MAT_W];
698:   if (ds->compact) {
699:     H[off] = d[ds->l]*s[ds->l];
700:     H[off+ld] = e[ds->l]*s[ds->l];
701:     for (i=ds->l+1;i<ds->n-1;i++) {
702:       H[i+(i-1)*ld] = e[i-1]*s[i];
703:       H[i+i*ld]     = d[i]*s[i];
704:       H[i+(i+1)*ld] = e[i]*s[i];
705:     }
706:     H[ds->n-1+(ds->n-2)*ld] = e[ds->n-2]*s[ds->n-1];
707:     H[ds->n-1+(ds->n-1)*ld] = d[ds->n-1]*s[ds->n-1];
708:   } else {
709:     s[ds->l] = PetscRealPart(B[off]);
710:     H[off] = A[off]*s[ds->l];
711:     H[off+ld] = A[off+ld]*s[ds->l];
712:     for (i=ds->l+1;i<ds->n-1;i++) {
713:       s[i] = PetscRealPart(B[i+i*ld]);
714:       H[i+(i-1)*ld] = A[i+(i-1)*ld]*s[i];
715:       H[i+i*ld]     = A[i+i*ld]*s[i];
716:       H[i+(i+1)*ld] = A[i+(i+1)*ld]*s[i];
717:     }
718:     s[ds->n-1] = PetscRealPart(B[ds->n-1+(ds->n-1)*ld]);
719:     H[ds->n-1+(ds->n-2)*ld] = A[ds->n-1+(ds->n-2)*ld]*s[ds->n-1];
720:     H[ds->n-1+(ds->n-1)*ld] = A[ds->n-1+(ds->n-1)*ld]*s[ds->n-1];
721:   }

723: #if !defined(PETSC_USE_COMPLEX)
724:   PetscStackCallBLAS("LAPACKhseqr",LAPACKhseqr_("E","N",&n1,&one,&n1,H+off,&ld,wr+ds->l,wi+ds->l,NULL,&ld,ds->work,&lwork,&info));
725: #else
726:   PetscStackCallBLAS("LAPACKhseqr",LAPACKhseqr_("E","N",&n1,&one,&n1,H+off,&ld,wr+ds->l,NULL,&ld,ds->work,&lwork,&info));

728:   /* Sort to have consecutive conjugate pairs */
729:   for (i=ds->l;i<ds->n;i++) {
730:       j=i+1;
731:       while (j<ds->n && (PetscAbsScalar(wr[i]-PetscConj(wr[j]))>PetscAbsScalar(wr[i])*PETSC_SQRT_MACHINE_EPSILON)) j++;
732:       if (j==ds->n) {
733:         if (PetscAbsReal(PetscImaginaryPart(wr[i]))<PetscAbsScalar(wr[i])*PETSC_SQRT_MACHINE_EPSILON) wr[i]=PetscRealPart(wr[i]);
734:         else SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"In QR_II complex without conjugate pair");
735:       } else { /* complex eigenvalue */
736:         wr[j] = wr[i+1];
737:         if (PetscImaginaryPart(wr[i])<0) wr[i] = PetscConj(wr[i]);
738:         wr[i+1] = PetscConj(wr[i]);
739:         i++;
740:       }
741:   }
742: #endif
743:   if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xHSEQR %d",&info);
744:   /* Compute Eigenvectors with Inverse Iteration */
745:   DSGHIEPInverseIteration(ds,wr,wi);

747:   /* Recover eigenvalues from diagonal */
748:   DSGHIEPComplexEigs(ds,0,ds->l,wr,wi);
749: #if defined(PETSC_USE_COMPLEX)
750:   if (wi) {
751:     for (i=ds->l;i<ds->n;i++) wi[i] = 0.0;
752:   }
753: #endif
754:   return(0);
755: #endif
756: }

760: PetscErrorCode DSSolve_GHIEP_QR(DS ds,PetscScalar *wr,PetscScalar *wi)
761: {
762: #if defined(SLEPC_MISSING_LAPACK_GEHRD) || defined(SLEPC_MISSING_LAPACK_ORGHR) || defined(PETSC_MISSING_LAPACK_HSEQR)
764:   SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GEHRD/ORGHR/HSEQR - Lapack routines are unavailable");
765: #else
767:   PetscInt       i,off,nwu=0,n,lw;
768:   PetscBLASInt   n_,ld,info,lwork;
769:   PetscScalar    *H,*A,*B,*Q,*X;
770:   PetscReal      *d,*s;
771: #if defined(PETSC_USE_COMPLEX)
772:   PetscInt       j,k;
773: #endif

776: #if !defined(PETSC_USE_COMPLEX)
778: #endif
779:   n = ds->n-ds->l;
780:   PetscBLASIntCast(n,&n_);
781:   PetscBLASIntCast(ds->ld,&ld);
782:   off = ds->l + ds->l*ld;
783:   A = ds->mat[DS_MAT_A];
784:   B = ds->mat[DS_MAT_B];
785:   Q = ds->mat[DS_MAT_Q];
786:   d = ds->rmat[DS_MAT_T];
787:   s = ds->rmat[DS_MAT_D];
788:   lw = 14*ld+ld*ld;
789:   DSAllocateWork_Private(ds,lw,2*ld,0);

791:   /* Quick return if possible */
792:   if (n_ == 1) {
793:     *(Q+off) = 1;
794:     if (!ds->compact) {
795:       d[ds->l] = PetscRealPart(A[off]);
796:       s[ds->l] = PetscRealPart(B[off]);
797:     }
798:     wr[ds->l] = d[ds->l]/s[ds->l];
799:     if (wi) wi[ds->l] = 0.0;
800:     return(0);
801:   }

803:   /* Form pseudo-symmetric matrix */
804:   H =  ds->work+nwu;
805:   nwu += n*n;
806:   PetscMemzero(H,n*n*sizeof(PetscScalar));
807:   if (ds->compact) {
808:     for (i=0;i<n-1;i++) {
809:       H[i+i*n]     = s[ds->l+i]*d[ds->l+i];
810:       H[i+1+i*n]   = s[ds->l+i+1]*d[ld+ds->l+i];
811:       H[i+(i+1)*n] = s[ds->l+i]*d[ld+ds->l+i];
812:     }
813:     H[n-1+(n-1)*n] = s[ds->l+n-1]*d[ds->l+n-1];
814:     for (i=0;i<ds->k-ds->l;i++) {
815:       H[ds->k-ds->l+i*n] = s[ds->k]*d[2*ld+ds->l+i];
816:       H[i+(ds->k-ds->l)*n] = s[i+ds->l]*d[2*ld+ds->l+i];
817:     }
818:   } else {
819:     for (i=0;i<n-1;i++) {
820:       H[i+i*n]     = B[off+i+i*ld]*A[off+i+i*ld];
821:       H[i+1+i*n]   = B[off+i+1+(i+1)*ld]*A[off+i+1+i*ld];
822:       H[i+(i+1)*n] = B[off+i+i*ld]*A[off+i+(i+1)*ld];
823:     }
824:     H[n-1+(n-1)*n] = B[off+n-1+(n-1)*ld]*A[off+n-1+(n-1)*n];
825:     for (i=0;i<ds->k-ds->l;i++) {
826:       H[ds->k-ds->l+i*n] = B[ds->k*(1+ld)]*A[off+ds->k-ds->l+i*ld];
827:       H[i+(ds->k-ds->l)*n] = B[(i+ds->l)*(1+ld)]*A[off+i+(ds->k-ds->l)*ld];
828:     }
829:   }
830:  
831:   /* Compute eigenpairs */
832:   PetscBLASIntCast(lw-nwu,&lwork);  
833:   DSAllocateMat_Private(ds,DS_MAT_X);
834:   X = ds->mat[DS_MAT_X];
835: #if !defined(PETSC_USE_COMPLEX)
836:   PetscStackCallBLAS("LAPACKgeev",LAPACKgeev_("N","V",&n_,H,&n_,wr+ds->l,wi+ds->l,NULL,&ld,X+off,&ld,ds->work+nwu,&lwork,&info));
837: #else
838:   PetscStackCallBLAS("LAPACKgeev",LAPACKgeev_("N","V",&n_,H,&n_,wr+ds->l,NULL,&ld,X+off,&ld,ds->work+nwu,&lwork,ds->rwork,&info));

840:   /* Sort to have consecutive conjugate pairs 
841:      Separate real and imaginary part of complex eigenvectors*/
842:   for (i=ds->l;i<ds->n;i++) {
843:     j=i+1;
844:     while (j<ds->n && (PetscAbsScalar(wr[i]-PetscConj(wr[j]))>PetscAbsScalar(wr[i])*PETSC_SQRT_MACHINE_EPSILON)) j++;
845:     if (j==ds->n) {
846:       if (PetscAbsReal(PetscImaginaryPart(wr[i]))<PetscAbsScalar(wr[i])*PETSC_SQRT_MACHINE_EPSILON) {
847:         wr[i]=PetscRealPart(wr[i]); /* real eigenvalue */
848:         for (k=ds->l;k<ds->n;k++) {
849:           X[k+i*ds->ld] = PetscRealPart(X[k+i*ds->ld]);
850:         }
851:       } else SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"In QR_II complex without conjugate pair");
852:     } else { /* complex eigenvalue */
853:       if (j!=i+1) {
854:         wr[j] = wr[i+1];
855:         PetscMemcpy(X+j*ds->ld,X+(i+1)*ds->ld,ds->ld*sizeof(PetscScalar));
856:       }
857:       if (PetscImaginaryPart(wr[i])<0) {
858:         wr[i] = PetscConj(wr[i]);
859:         for (k=ds->l;k<ds->n;k++) {
860:           X[k+(i+1)*ds->ld] = -PetscImaginaryPart(X[k+i*ds->ld]);
861:           X[k+i*ds->ld] = PetscRealPart(X[k+i*ds->ld]);
862:         }
863:       } else {
864:         for (k=ds->l;k<ds->n;k++) {
865:           X[k+(i+1)*ds->ld] = PetscImaginaryPart(X[k+i*ds->ld]);
866:           X[k+i*ds->ld] = PetscRealPart(X[k+i*ds->ld]);
867:         }
868:       }
869:       wr[i+1] = PetscConj(wr[i]);
870:       i++;
871:     }
872:   }
873: #endif
874:   if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xHSEQR %d",&info);

876:   /* Compute real s-orthonormal basis */
877:   DSGHIEPOrthogEigenv(ds,DS_MAT_X,wr,wi,PETSC_FALSE);

879:   /* Recover eigenvalues from diagonal */
880:   DSGHIEPComplexEigs(ds,0,ds->l,wr,wi);
881: #if defined(PETSC_USE_COMPLEX)
882:   if (wi) {
883:     for (i=ds->l;i<ds->n;i++) wi[i] = 0.0;
884:   }
885: #endif
886:   return(0);
887: #endif
888: }

892: PetscErrorCode DSNormalize_GHIEP(DS ds,DSMatType mat,PetscInt col)
893: {
895:   PetscInt       i,i0,i1;
896:   PetscBLASInt   ld,n,one = 1;
897:   PetscScalar    *A = ds->mat[DS_MAT_A],norm,*x;
898: #if !defined(PETSC_USE_COMPLEX)
899:   PetscScalar    norm0;
900: #endif

903:   switch (mat) {
904:     case DS_MAT_X:
905:     case DS_MAT_Y:
906:     case DS_MAT_Q:
907:       /* Supported matrices */
908:       break;
909:     case DS_MAT_U:
910:     case DS_MAT_VT:
911:       SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Not implemented yet");
912:       break;
913:     default:
914:       SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid mat parameter");
915:   }

917:   PetscBLASIntCast(ds->n,&n);
918:   PetscBLASIntCast(ds->ld,&ld);
919:   DSGetArray(ds,mat,&x);
920:   if (col < 0) {
921:     i0 = 0; i1 = ds->n;
922:   } else if (col>0 && A[ds->ld*(col-1)+col] != 0.0) {
923:     i0 = col-1; i1 = col+1;
924:   } else {
925:     i0 = col; i1 = col+1;
926:   }
927:   for (i=i0; i<i1; i++) {
928: #if !defined(PETSC_USE_COMPLEX)
929:     if (i<n-1 && A[ds->ld*i+i+1] != 0.0) {
930:       norm = BLASnrm2_(&n,&x[ld*i],&one);
931:       norm0 = BLASnrm2_(&n,&x[ld*(i+1)],&one);
932:       norm = 1.0/SlepcAbsEigenvalue(norm,norm0);
933:       PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*i],&one));
934:       PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*(i+1)],&one));
935:       i++;
936:     } else
937: #endif
938:     {
939:       norm = BLASnrm2_(&n,&x[ld*i],&one);
940:       norm = 1.0/norm;
941:       PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*i],&one));
942:     }
943:   }
944:   return(0);
945: }

949: PETSC_EXTERN PetscErrorCode DSCreate_GHIEP(DS ds)
950: {
952:   ds->ops->allocate      = DSAllocate_GHIEP;
953:   ds->ops->view          = DSView_GHIEP;
954:   ds->ops->vectors       = DSVectors_GHIEP;
955:   ds->ops->solve[0]      = DSSolve_GHIEP_HZ;
956:   ds->ops->solve[1]      = DSSolve_GHIEP_QR_II;
957:   ds->ops->solve[2]      = DSSolve_GHIEP_QR;
958:   ds->ops->solve[3]      = DSSolve_GHIEP_DQDS_II;
959:   ds->ops->sort          = DSSort_GHIEP;
960:   ds->ops->normalize     = DSNormalize_GHIEP;
961:   return(0);
962: }