Actual source code: dsgnhep.c
slepc-3.7.2 2016-07-19
1: /*
2: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3: SLEPc - Scalable Library for Eigenvalue Problem Computations
4: Copyright (c) 2002-2016, 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>
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: PetscMalloc1(ld,&ds->perm);
57: PetscLogObjectMemory((PetscObject)ds,ld*sizeof(PetscInt));
58: return(0);
59: }
63: PetscErrorCode DSView_GNHEP(DS ds,PetscViewer viewer)
64: {
68: DSViewMat(ds,viewer,DS_MAT_A);
69: DSViewMat(ds,viewer,DS_MAT_B);
70: if (ds->state>DS_STATE_INTERMEDIATE) {
71: DSViewMat(ds,viewer,DS_MAT_Z);
72: DSViewMat(ds,viewer,DS_MAT_Q);
73: }
74: if (ds->mat[DS_MAT_X]) {
75: DSViewMat(ds,viewer,DS_MAT_X);
76: }
77: if (ds->mat[DS_MAT_Y]) {
78: DSViewMat(ds,viewer,DS_MAT_Y);
79: }
80: return(0);
81: }
85: static PetscErrorCode DSVectors_GNHEP_Eigen_Some(DS ds,PetscInt *k,PetscReal *rnorm,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,inc = 1;
94: PetscScalar *X,*Y,*Z,*A = ds->mat[DS_MAT_A],*B = ds->mat[DS_MAT_B],tmp,fone=1.0,fzero=0.0;
95: PetscReal norm;
96: PetscBool iscomplex = PETSC_FALSE;
97: const char *side;
100: PetscBLASIntCast(ds->n,&n);
101: PetscBLASIntCast(ds->ld,&ld);
102: if (left) {
103: X = NULL;
104: Y = &ds->mat[DS_MAT_Y][ld*(*k)];
105: side = "L";
106: } else {
107: X = &ds->mat[DS_MAT_X][ld*(*k)];
108: Y = NULL;
109: side = "R";
110: }
111: Z = left? Y: X;
112: DSAllocateWork_Private(ds,0,0,ld);
113: select = ds->iwork;
114: for (i=0;i<n;i++) select[i] = (PetscBLASInt)PETSC_FALSE;
115: if (ds->state <= DS_STATE_INTERMEDIATE) {
116: DSSetIdentity(ds,DS_MAT_Q);
117: DSSetIdentity(ds,DS_MAT_Z);
118: }
119: CleanDenseSchur(n,0,A,ld,B,ld,ds->mat[DS_MAT_Q],ld,ds->mat[DS_MAT_Z],ld,PETSC_TRUE);
120: if (ds->state < DS_STATE_CONDENSED) {
121: DSSetState(ds,DS_STATE_CONDENSED);
122: }
124: /* compute k-th eigenvector */
125: select[*k] = (PetscBLASInt)PETSC_TRUE;
126: #if defined(PETSC_USE_COMPLEX)
127: mm = 1;
128: DSAllocateWork_Private(ds,2*ld,2*ld,0);
129: PetscStackCallBLAS("LAPACKtgevc",LAPACKtgevc_(side,"S",select,&n,A,&ld,B,&ld,Y,&ld,X,&ld,&mm,&mout,ds->work,ds->rwork,&info));
130: #else
131: if ((*k)<n-1 && (A[ld*(*k)+(*k)+1] != 0.0 || B[ld*(*k)+(*k)+1] != 0.0)) iscomplex = PETSC_TRUE;
132: mm = iscomplex? 2: 1;
133: DSAllocateWork_Private(ds,6*ld,0,0);
134: PetscStackCallBLAS("LAPACKtgevc",LAPACKtgevc_(side,"S",select,&n,A,&ld,B,&ld,Y,&ld,X,&ld,&mm,&mout,ds->work,&info));
135: #endif
136: if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xTGEVC %i",info);
137: if (!select[*k] || mout != mm) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_WRONG,"Wrong arguments in call to Lapack xTGEVC");
139: /* accumulate and normalize eigenvectors */
140: PetscMemcpy(ds->work,Z,mm*ld*sizeof(PetscScalar));
141: PetscStackCallBLAS("BLASgemm",BLASgemm_("N","N",&n,&mm,&n,&fone,ds->mat[left?DS_MAT_Z:DS_MAT_Q],&ld,ds->work,&ld,&fzero,Z,&ld));
142: norm = BLASnrm2_(&n,Z,&inc);
143: #if !defined(PETSC_USE_COMPLEX)
144: if (iscomplex) {
145: tmp = BLASnrm2_(&n,Z+ld,&inc);
146: norm = SlepcAbsEigenvalue(norm,tmp);
147: }
148: #endif
149: tmp = 1.0 / norm;
150: PetscStackCallBLAS("BLASscal",BLASscal_(&n,&tmp,Z,&inc));
151: #if !defined(PETSC_USE_COMPLEX)
152: if (iscomplex) PetscStackCallBLAS("BLASscal",BLASscal_(&n,&tmp,Z+ld,&inc));
153: #endif
155: /* set output arguments */
156: if (iscomplex) (*k)++;
157: if (rnorm) {
158: if (iscomplex) *rnorm = SlepcAbsEigenvalue(Z[n-1],Z[n-1+ld]);
159: else *rnorm = PetscAbsScalar(Z[n-1]);
160: }
161: return(0);
162: #endif
163: }
167: static PetscErrorCode DSVectors_GNHEP_Eigen_All(DS ds,PetscBool left)
168: {
169: #if defined(SLEPC_MISSING_LAPACK_TGEVC)
171: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"TGEVC - Lapack routine is unavailable");
172: #else
174: PetscInt i;
175: PetscBLASInt n,ld,mout,info,inc = 1;
176: PetscBool iscomplex = PETSC_FALSE;
177: PetscScalar *X,*Y,*Z,*A = ds->mat[DS_MAT_A],*B = ds->mat[DS_MAT_B],tmp;
178: PetscReal norm;
179: const char *side,*back;
182: PetscBLASIntCast(ds->n,&n);
183: PetscBLASIntCast(ds->ld,&ld);
184: if (left) {
185: X = NULL;
186: Y = ds->mat[DS_MAT_Y];
187: side = "L";
188: } else {
189: X = ds->mat[DS_MAT_X];
190: Y = NULL;
191: side = "R";
192: }
193: Z = left? Y: X;
194: if (ds->state <= DS_STATE_INTERMEDIATE) {
195: DSSetIdentity(ds,DS_MAT_Q);
196: DSSetIdentity(ds,DS_MAT_Z);
197: }
198: CleanDenseSchur(n,0,A,ld,B,ld,ds->mat[DS_MAT_Q],ld,ds->mat[DS_MAT_Z],ld,PETSC_TRUE);
199: if (ds->state>=DS_STATE_CONDENSED) {
200: /* DSSolve() has been called, backtransform with matrix Q */
201: back = "B";
202: PetscMemcpy(left?Y:X,ds->mat[left?DS_MAT_Z:DS_MAT_Q],ld*ld*sizeof(PetscScalar));
203: } else {
204: back = "A";
205: DSSetState(ds,DS_STATE_CONDENSED);
206: }
207: #if defined(PETSC_USE_COMPLEX)
208: DSAllocateWork_Private(ds,2*ld,2*ld,0);
209: PetscStackCallBLAS("LAPACKtgevc",LAPACKtgevc_(side,back,NULL,&n,A,&ld,B,&ld,Y,&ld,X,&ld,&n,&mout,ds->work,ds->rwork,&info));
210: #else
211: DSAllocateWork_Private(ds,6*ld,0,0);
212: PetscStackCallBLAS("LAPACKtgevc",LAPACKtgevc_(side,back,NULL,&n,A,&ld,B,&ld,Y,&ld,X,&ld,&n,&mout,ds->work,&info));
213: #endif
214: if (info) SETERRQ1(PetscObjectComm((PetscObject)ds),PETSC_ERR_LIB,"Error in Lapack xTGEVC %i",info);
216: /* normalize eigenvectors */
217: for (i=0;i<n;i++) {
218: if (i<n-1 && (A[i+1+i*ld]!=0.0 || B[i+1+i*ld]!=0.0)) iscomplex = PETSC_TRUE;
219: norm = BLASnrm2_(&n,Z+i*ld,&inc);
220: #if !defined(PETSC_USE_COMPLEX)
221: if (iscomplex) {
222: tmp = BLASnrm2_(&n,Z+(i+1)*ld,&inc);
223: norm = SlepcAbsEigenvalue(norm,tmp);
224: }
225: #endif
226: tmp = 1.0 / norm;
227: PetscStackCallBLAS("BLASscal",BLASscal_(&n,&tmp,Z+i*ld,&inc));
228: #if !defined(PETSC_USE_COMPLEX)
229: if (iscomplex) PetscStackCallBLAS("BLASscal",BLASscal_(&n,&tmp,Z+(i+1)*ld,&inc));
230: #endif
231: if (iscomplex) i++;
232: }
233: return(0);
234: #endif
235: }
239: PetscErrorCode DSVectors_GNHEP(DS ds,DSMatType mat,PetscInt *k,PetscReal *rnorm)
240: {
244: switch (mat) {
245: case DS_MAT_X:
246: case DS_MAT_Y:
247: if (k) {
248: DSVectors_GNHEP_Eigen_Some(ds,k,rnorm,mat == DS_MAT_Y?PETSC_TRUE:PETSC_FALSE);
249: } else {
250: DSVectors_GNHEP_Eigen_All(ds,mat == DS_MAT_Y?PETSC_TRUE:PETSC_FALSE);
251: }
252: break;
253: default:
254: SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid mat parameter");
255: }
256: return(0);
257: }
261: PetscErrorCode DSNormalize_GNHEP(DS ds,DSMatType mat,PetscInt col)
262: {
264: PetscInt i,i0,i1;
265: PetscBLASInt ld,n,one = 1;
266: PetscScalar *A = ds->mat[DS_MAT_A],*B = ds->mat[DS_MAT_B],norm,*x;
267: #if !defined(PETSC_USE_COMPLEX)
268: PetscScalar norm0;
269: #endif
272: switch (mat) {
273: case DS_MAT_X:
274: case DS_MAT_Y:
275: case DS_MAT_Q:
276: case DS_MAT_Z:
277: /* Supported matrices */
278: break;
279: case DS_MAT_U:
280: case DS_MAT_VT:
281: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Not implemented yet");
282: break;
283: default:
284: SETERRQ(PetscObjectComm((PetscObject)ds),PETSC_ERR_ARG_OUTOFRANGE,"Invalid mat parameter");
285: }
287: PetscBLASIntCast(ds->n,&n);
288: PetscBLASIntCast(ds->ld,&ld);
289: DSGetArray(ds,mat,&x);
290: if (col < 0) {
291: i0 = 0; i1 = ds->n;
292: } else if (col>0 && (A[ds->ld*(col-1)+col] != 0.0 || (B && B[ds->ld*(col-1)+col] != 0.0))) {
293: i0 = col-1; i1 = col+1;
294: } else {
295: i0 = col; i1 = col+1;
296: }
297: for (i=i0;i<i1;i++) {
298: #if !defined(PETSC_USE_COMPLEX)
299: if (i<n-1 && (A[ds->ld*i+i+1] != 0.0 || (B && B[ds->ld*i+i+1] != 0.0))) {
300: norm = BLASnrm2_(&n,&x[ld*i],&one);
301: norm0 = BLASnrm2_(&n,&x[ld*(i+1)],&one);
302: norm = 1.0/SlepcAbsEigenvalue(norm,norm0);
303: PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*i],&one));
304: PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*(i+1)],&one));
305: i++;
306: } else
307: #endif
308: {
309: norm = BLASnrm2_(&n,&x[ld*i],&one);
310: norm = 1.0/norm;
311: PetscStackCallBLAS("BLASscal",BLASscal_(&n,&norm,&x[ld*i],&one));
312: }
313: }
314: return(0);
315: }
319: static PetscErrorCode DSSort_GNHEP_Arbitrary(DS ds,PetscScalar *wr,PetscScalar *wi,PetscScalar *rr,PetscScalar *ri,PetscInt *k)
320: {
321: #if defined(PETSC_MISSING_LAPACK_TGSEN)
323: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"TGSEN - Lapack routine is unavailable");
324: #else
326: PetscInt i;
327: PetscBLASInt info,n,ld,mout,lwork,liwork,*iwork,*selection,zero_=0,true_=1;
328: 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;
331: if (!ds->sc) return(0);
332: PetscBLASIntCast(ds->n,&n);
333: PetscBLASIntCast(ds->ld,&ld);
334: #if !defined(PETSC_USE_COMPLEX)
335: lwork = 4*n+16;
336: #else
337: lwork = 1;
338: #endif
339: liwork = 1;
340: DSAllocateWork_Private(ds,lwork+2*n,0,liwork+n);
341: beta = ds->work;
342: work = ds->work + n;
343: lwork = ds->lwork - n;
344: selection = ds->iwork;
345: iwork = ds->iwork + n;
346: liwork = ds->liwork - n;
347: /* Compute the selected eigenvalue to be in the leading position */
348: DSSortEigenvalues_Private(ds,rr,ri,ds->perm,PETSC_FALSE);
349: PetscMemzero(selection,n*sizeof(PetscBLASInt));
350: for (i=0; i<*k; i++) selection[ds->perm[i]] = 1;
351: #if !defined(PETSC_USE_COMPLEX)
352: 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));
353: #else
354: 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));
355: #endif
356: if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xTGSEN %d",info);
357: *k = mout;
358: for (i=0;i<n;i++) {
359: if (beta[i]==0.0) wr[i] = (PetscRealPart(wr[i])>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
360: else wr[i] /= beta[i];
361: #if !defined(PETSC_USE_COMPLEX)
362: if (beta[i]==0.0) wi[i] = (wi[i]>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
363: else wi[i] /= beta[i];
364: #endif
365: }
366: return(0);
367: #endif
368: }
372: static PetscErrorCode DSSort_GNHEP_Total(DS ds,PetscScalar *wr,PetscScalar *wi)
373: {
374: #if defined(SLEPC_MISSING_LAPACK_TGEXC) || !defined(PETSC_USE_COMPLEX) && (defined(SLEPC_MISSING_LAPACK_LAMCH) || defined(SLEPC_MISSING_LAPACK_LAG2))
376: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"TGEXC/LAMCH/LAG2 - Lapack routines are unavailable");
377: #else
379: PetscScalar re;
380: PetscInt i,j,pos,result;
381: PetscBLASInt ifst,ilst,info,n,ld,one=1;
382: 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];
383: #if !defined(PETSC_USE_COMPLEX)
384: PetscBLASInt lwork;
385: PetscScalar *work,a,safmin,scale1,scale2,im;
386: #endif
389: if (!ds->sc) return(0);
390: PetscBLASIntCast(ds->n,&n);
391: PetscBLASIntCast(ds->ld,&ld);
392: #if !defined(PETSC_USE_COMPLEX)
393: lwork = -1;
394: PetscStackCallBLAS("LAPACKtgexc",LAPACKtgexc_(&one,&one,&ld,NULL,&ld,NULL,&ld,NULL,&ld,NULL,&ld,&one,&one,&a,&lwork,&info));
395: safmin = LAPACKlamch_("S");
396: PetscBLASIntCast((PetscInt)a,&lwork);
397: DSAllocateWork_Private(ds,lwork,0,0);
398: work = ds->work;
399: #endif
400: /* selection sort */
401: for (i=ds->l;i<n-1;i++) {
402: re = wr[i];
403: #if !defined(PETSC_USE_COMPLEX)
404: im = wi[i];
405: #endif
406: pos = 0;
407: j = i+1; /* j points to the next eigenvalue */
408: #if !defined(PETSC_USE_COMPLEX)
409: if (im != 0) j=i+2;
410: #endif
411: /* find minimum eigenvalue */
412: for (;j<n;j++) {
413: #if !defined(PETSC_USE_COMPLEX)
414: SlepcSCCompare(ds->sc,re,im,wr[j],wi[j],&result);
415: #else
416: SlepcSCCompare(ds->sc,re,0.0,wr[j],0.0,&result);
417: #endif
418: if (result > 0) {
419: re = wr[j];
420: #if !defined(PETSC_USE_COMPLEX)
421: im = wi[j];
422: #endif
423: pos = j;
424: }
425: #if !defined(PETSC_USE_COMPLEX)
426: if (wi[j] != 0) j++;
427: #endif
428: }
429: if (pos) {
430: /* interchange blocks */
431: PetscBLASIntCast(pos+1,&ifst);
432: PetscBLASIntCast(i+1,&ilst);
433: #if !defined(PETSC_USE_COMPLEX)
434: PetscStackCallBLAS("LAPACKtgexc",LAPACKtgexc_(&one,&one,&n,S,&ld,T,&ld,Z,&ld,Q,&ld,&ifst,&ilst,work,&lwork,&info));
435: #else
436: PetscStackCallBLAS("LAPACKtgexc",LAPACKtgexc_(&one,&one,&n,S,&ld,T,&ld,Z,&ld,Q,&ld,&ifst,&ilst,&info));
437: #endif
438: if (info) SETERRQ1(PetscObjectComm((PetscObject)ds),PETSC_ERR_LIB,"Error in Lapack xTGEXC %i",info);
439: /* recover original eigenvalues from T and S matrices */
440: for (j=i;j<n;j++) {
441: #if !defined(PETSC_USE_COMPLEX)
442: if (j<n-1 && S[j*ld+j+1] != 0.0) {
443: /* complex conjugate eigenvalue */
444: PetscStackCallBLAS("LAPACKlag2",LAPACKlag2_(S+j*ld+j,&ld,T+j*ld+j,&ld,&safmin,&scale1,&scale2,&re,&a,&im));
445: wr[j] = re / scale1;
446: wi[j] = im / scale1;
447: wr[j+1] = a / scale2;
448: wi[j+1] = -wi[j];
449: j++;
450: } else
451: #endif
452: {
453: if (T[j*ld+j] == 0.0) wr[j] = (PetscRealPart(S[j*ld+j])>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
454: else wr[j] = S[j*ld+j] / T[j*ld+j];
455: #if !defined(PETSC_USE_COMPLEX)
456: wi[j] = 0.0;
457: #endif
458: }
459: }
460: }
461: #if !defined(PETSC_USE_COMPLEX)
462: if (wi[i] != 0.0) i++;
463: #endif
464: }
465: return(0);
466: #endif
467: }
471: PetscErrorCode DSSort_GNHEP(DS ds,PetscScalar *wr,PetscScalar *wi,PetscScalar *rr,PetscScalar *ri,PetscInt *k)
472: {
476: if (!rr || wr == rr) {
477: DSSort_GNHEP_Total(ds,wr,wi);
478: } else {
479: DSSort_GNHEP_Arbitrary(ds,wr,wi,rr,ri,k);
480: }
481: return(0);
482: }
486: /*
487: Write zeros from the column k to n in the lower triangular part of the
488: matrices S and T, and inside 2-by-2 diagonal blocks of T in order to
489: make (S,T) a valid Schur decompositon.
490: */
491: 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)
492: {
493: #if defined(SLEPC_MISSING_LAPACK_LASV2)
495: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"LASV2 - Lapack routine is unavailable");
496: #else
497: PetscInt i,j;
498: #if defined(PETSC_USE_COMPLEX)
499: PetscScalar s;
500: #else
502: PetscBLASInt ldS_,ldT_,n_i,n_i_2,one=1,n_,i_2,i_;
503: PetscScalar b11,b22,sr,cr,sl,cl;
504: #endif
507: if (!doProd && X) {
508: for (i=0;i<n;i++) for (j=0;j<n;j++) X[ldX*i+j] = 0.0;
509: for (i=0;i<n;i++) X[ldX*i+i] = 1.0;
510: }
511: if (!doProd && Y) {
512: for (i=0;i<n;i++) for (j=0;j<n;j++) Y[ldY*i+j] = 0.0;
513: for (i=0;i<n;i++) Y[ldX*i+i] = 1.0;
514: }
516: #if defined(PETSC_USE_COMPLEX)
517: for (i=k; i<n; i++) {
518: /* Some functions need the diagonal elements in T be real */
519: if (T && PetscImaginaryPart(T[ldT*i+i]) != 0.0) {
520: s = PetscConj(T[ldT*i+i])/PetscAbsScalar(T[ldT*i+i]);
521: for (j=0;j<=i;j++) {
522: T[ldT*i+j] *= s;
523: S[ldS*i+j] *= s;
524: }
525: T[ldT*i+i] = PetscRealPart(T[ldT*i+i]);
526: if (X) for (j=0;j<n;j++) X[ldX*i+j] *= s;
527: }
528: j = i+1;
529: if (j<n) {
530: S[ldS*i+j] = 0.0;
531: if (T) T[ldT*i+j] = 0.0;
532: }
533: }
534: #else
535: PetscBLASIntCast(ldS,&ldS_);
536: PetscBLASIntCast(ldT,&ldT_);
537: PetscBLASIntCast(n,&n_);
538: for (i=k;i<n-1;i++) {
539: if (S[ldS*i+i+1] != 0.0) {
540: /* Check if T(i+1,i) and T(i,i+1) are zero */
541: if (T[ldT*(i+1)+i] != 0.0 || T[ldT*i+i+1] != 0.0) {
542: /* Check if T(i+1,i) and T(i,i+1) are negligible */
543: 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) {
544: T[ldT*i+i+1] = 0.0;
545: T[ldT*(i+1)+i] = 0.0;
547: } else {
548: /* If one of T(i+1,i) or T(i,i+1) is negligible, we make zero the other element */
549: 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) {
550: PetscStackCallBLAS("LAPACKlasv2",LAPACKlasv2_(&T[ldT*i+i],&T[ldT*(i+1)+i],&T[ldT*(i+1)+i+1],&b22,&b11,&sl,&cl,&sr,&cr));
551: } 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) {
552: PetscStackCallBLAS("LAPACKlasv2",LAPACKlasv2_(&T[ldT*i+i],&T[ldT*i+i+1],&T[ldT*(i+1)+i+1],&b22,&b11,&sr,&cr,&sl,&cl));
553: } else {
554: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Unsupported format. Call DSSolve before this function");
555: }
556: PetscBLASIntCast(n-i,&n_i);
557: n_i_2 = n_i - 2;
558: PetscBLASIntCast(i+2,&i_2);
559: PetscBLASIntCast(i,&i_);
560: if (b11 < 0.0) {
561: cr = -cr;
562: sr = -sr;
563: b11 = -b11;
564: b22 = -b22;
565: }
566: PetscStackCallBLAS("BLASrot",BLASrot_(&n_i,&S[ldS*i+i],&ldS_,&S[ldS*i+i+1],&ldS_,&cl,&sl));
567: PetscStackCallBLAS("BLASrot",BLASrot_(&i_2,&S[ldS*i],&one,&S[ldS*(i+1)],&one,&cr,&sr));
568: PetscStackCallBLAS("BLASrot",BLASrot_(&n_i_2,&T[ldT*(i+2)+i],&ldT_,&T[ldT*(i+2)+i+1],&ldT_,&cl,&sl));
569: PetscStackCallBLAS("BLASrot",BLASrot_(&i_,&T[ldT*i],&one,&T[ldT*(i+1)],&one,&cr,&sr));
570: if (X) PetscStackCallBLAS("BLASrot",BLASrot_(&n_,&X[ldX*i],&one,&X[ldX*(i+1)],&one,&cr,&sr));
571: if (Y) PetscStackCallBLAS("BLASrot",BLASrot_(&n_,&Y[ldY*i],&one,&Y[ldY*(i+1)],&one,&cl,&sl));
572: T[ldT*i+i] = b11;
573: T[ldT*i+i+1] = 0.0;
574: T[ldT*(i+1)+i] = 0.0;
575: T[ldT*(i+1)+i+1] = b22;
576: }
577: }
578: i++;
579: }
580: }
581: #endif
582: return(0);
583: #endif
584: }
588: PetscErrorCode DSSolve_GNHEP(DS ds,PetscScalar *wr,PetscScalar *wi)
589: {
590: #if defined(PETSC_MISSING_LAPACK_GGES)
592: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GGES - Lapack routines are unavailable");
593: #else
595: PetscScalar *work,*beta,a;
596: PetscInt i;
597: PetscBLASInt lwork,info,n,ld,iaux;
598: 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];
601: #if !defined(PETSC_USE_COMPLEX)
603: #endif
604: PetscBLASIntCast(ds->n,&n);
605: PetscBLASIntCast(ds->ld,&ld);
606: lwork = -1;
607: #if !defined(PETSC_USE_COMPLEX)
608: PetscStackCallBLAS("LAPACKgges",LAPACKgges_("V","V","N",NULL,&n,A,&ld,B,&ld,&iaux,wr,wi,NULL,Z,&ld,Q,&ld,&a,&lwork,NULL,&info));
609: PetscBLASIntCast((PetscInt)a,&lwork);
610: DSAllocateWork_Private(ds,lwork+ld,0,0);
611: beta = ds->work;
612: work = beta+ds->n;
613: PetscBLASIntCast(ds->lwork-ds->n,&lwork);
614: PetscStackCallBLAS("LAPACKgges",LAPACKgges_("V","V","N",NULL,&n,A,&ld,B,&ld,&iaux,wr,wi,beta,Z,&ld,Q,&ld,work,&lwork,NULL,&info));
615: #else
616: PetscStackCallBLAS("LAPACKgges",LAPACKgges_("V","V","N",NULL,&n,A,&ld,B,&ld,&iaux,wr,NULL,Z,&ld,Q,&ld,&a,&lwork,NULL,NULL,&info));
617: PetscBLASIntCast((PetscInt)PetscRealPart(a),&lwork);
618: DSAllocateWork_Private(ds,lwork+ld,8*ld,0);
619: beta = ds->work;
620: work = beta+ds->n;
621: PetscBLASIntCast(ds->lwork-ds->n,&lwork);
622: 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));
623: #endif
624: if (info) SETERRQ1(PetscObjectComm((PetscObject)ds),PETSC_ERR_LIB,"Error in Lapack xGGES %i",info);
625: for (i=0;i<n;i++) {
626: if (beta[i]==0.0) wr[i] = (PetscRealPart(wr[i])>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
627: else wr[i] /= beta[i];
628: #if !defined(PETSC_USE_COMPLEX)
629: if (beta[i]==0.0) wi[i] = (wi[i]>0.0)? PETSC_MAX_REAL: PETSC_MIN_REAL;
630: else wi[i] /= beta[i];
631: #else
632: if (wi) wi[i] = 0.0;
633: #endif
634: }
635: return(0);
636: #endif
637: }
641: PETSC_EXTERN PetscErrorCode DSCreate_GNHEP(DS ds)
642: {
644: ds->ops->allocate = DSAllocate_GNHEP;
645: ds->ops->view = DSView_GNHEP;
646: ds->ops->vectors = DSVectors_GNHEP;
647: ds->ops->solve[0] = DSSolve_GNHEP;
648: ds->ops->sort = DSSort_GNHEP;
649: ds->ops->normalize = DSNormalize_GNHEP;
650: return(0);
651: }