Actual source code: gmreig.c
petsc-3.7.3 2016-07-24
2: #include <../src/ksp/ksp/impls/gmres/gmresimpl.h>
3: #include <petscblaslapack.h>
7: PetscErrorCode KSPComputeExtremeSingularValues_GMRES(KSP ksp,PetscReal *emax,PetscReal *emin)
8: {
9: #if defined(PETSC_MISSING_LAPACK_GESVD)
11: /*
12: The Cray math libraries on T3D/T3E, and early versions of Intel Math Kernel Libraries (MKL)
13: for PCs do not seem to have the DGESVD() lapack routines
14: */
15: SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"GESVD - Lapack routine is unavailable\nNot able to provide singular value estimates.");
16: #else
17: KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
19: PetscInt n = gmres->it + 1,i,N = gmres->max_k + 2;
20: PetscBLASInt bn, bN,lwork, idummy,lierr;
21: PetscScalar *R = gmres->Rsvd,*work = R + N*N,sdummy;
22: PetscReal *realpart = gmres->Dsvd;
25: PetscBLASIntCast(n,&bn);
26: PetscBLASIntCast(N,&bN);
27: PetscBLASIntCast(5*N,&lwork);
28: PetscBLASIntCast(N,&idummy);
29: if (n <= 0) {
30: *emax = *emin = 1.0;
31: return(0);
32: }
33: /* copy R matrix to work space */
34: PetscMemcpy(R,gmres->hh_origin,(gmres->max_k+2)*(gmres->max_k+1)*sizeof(PetscScalar));
36: /* zero below diagonal garbage */
37: for (i=0; i<n; i++) R[i*N+i+1] = 0.0;
39: /* compute Singular Values */
40: PetscFPTrapPush(PETSC_FP_TRAP_OFF);
41: #if !defined(PETSC_USE_COMPLEX)
42: PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("N","N",&bn,&bn,R,&bN,realpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,&lierr));
43: #else
44: PetscStackCallBLAS("LAPACKgesvd",LAPACKgesvd_("N","N",&bn,&bn,R,&bN,realpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,realpart+N,&lierr));
45: #endif
46: if (lierr) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in SVD Lapack routine %d",(int)lierr);
47: PetscFPTrapPop();
49: *emin = realpart[n-1];
50: *emax = realpart[0];
51: #endif
52: return(0);
53: }
55: /* ------------------------------------------------------------------------ */
56: /* ESSL has a different calling sequence for dgeev() and zgeev() than standard LAPACK */
59: PetscErrorCode KSPComputeEigenvalues_GMRES(KSP ksp,PetscInt nmax,PetscReal *r,PetscReal *c,PetscInt *neig)
60: {
61: #if defined(PETSC_HAVE_ESSL)
62: KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
64: PetscInt n = gmres->it + 1,N = gmres->max_k + 1;
65: PetscInt i,*perm;
66: PetscScalar *R = gmres->Rsvd;
67: PetscScalar *cwork = R + N*N,sdummy;
68: PetscReal *work,*realpart = gmres->Dsvd;
69: PetscBLASInt zero = 0,bn,bN,idummy,lwork;
72: PetscBLASIntCast(n,&bn);
73: PetscBLASIntCast(N,&bN);
74: idummy = -1; /* unused */
75: PetscBLASIntCast(5*N,&lwork);
76: if (nmax < n) SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_ARG_SIZ,"Not enough room in work space r and c for eigenvalues");
77: *neig = n;
79: if (!n) return(0);
81: /* copy R matrix to work space */
82: PetscMemcpy(R,gmres->hes_origin,N*N*sizeof(PetscScalar));
84: /* compute eigenvalues */
86: /* for ESSL version need really cwork of length N (complex), 2N
87: (real); already at least 5N of space has been allocated */
89: PetscMalloc1(lwork,&work);
90: PetscFPTrapPush(PETSC_FP_TRAP_OFF);
91: PetscStackCallBLAS("LAPACKgeev",LAPACKgeev_(&zero,R,&bN,cwork,&sdummy,&idummy,&idummy,&bn,work,&lwork));
92: PetscFPTrapPop();
93: PetscFree(work);
95: /* For now we stick with the convention of storing the real and imaginary
96: components of evalues separately. But is this what we really want? */
97: PetscMalloc1(n,&perm);
99: #if !defined(PETSC_USE_COMPLEX)
100: for (i=0; i<n; i++) {
101: realpart[i] = cwork[2*i];
102: perm[i] = i;
103: }
104: PetscSortRealWithPermutation(n,realpart,perm);
105: for (i=0; i<n; i++) {
106: r[i] = cwork[2*perm[i]];
107: c[i] = cwork[2*perm[i]+1];
108: }
109: #else
110: for (i=0; i<n; i++) {
111: realpart[i] = PetscRealPart(cwork[i]);
112: perm[i] = i;
113: }
114: PetscSortRealWithPermutation(n,realpart,perm);
115: for (i=0; i<n; i++) {
116: r[i] = PetscRealPart(cwork[perm[i]]);
117: c[i] = PetscImaginaryPart(cwork[perm[i]]);
118: }
119: #endif
120: PetscFree(perm);
121: #elif defined(PETSC_MISSING_LAPACK_GEEV)
123: SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"GEEV - Lapack routine is unavailable\nNot able to provide eigen values.");
124: #elif !defined(PETSC_USE_COMPLEX)
125: KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
127: PetscInt n = gmres->it + 1,N = gmres->max_k + 1,i,*perm;
128: PetscBLASInt bn, bN, lwork, idummy, lierr;
129: PetscScalar *R = gmres->Rsvd,*work = R + N*N;
130: PetscScalar *realpart = gmres->Dsvd,*imagpart = realpart + N,sdummy;
133: PetscBLASIntCast(n,&bn);
134: PetscBLASIntCast(N,&bN);
135: PetscBLASIntCast(5*N,&lwork);
136: PetscBLASIntCast(N,&idummy);
137: if (nmax < n) SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_ARG_SIZ,"Not enough room in work space r and c for eigenvalues");
138: *neig = n;
140: if (!n) return(0);
142: /* copy R matrix to work space */
143: PetscMemcpy(R,gmres->hes_origin,N*N*sizeof(PetscScalar));
145: /* compute eigenvalues */
146: PetscFPTrapPush(PETSC_FP_TRAP_OFF);
147: PetscStackCallBLAS("LAPACKgeev",LAPACKgeev_("N","N",&bn,R,&bN,realpart,imagpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,&lierr));
148: if (lierr) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in LAPACK routine %d",(int)lierr);
149: PetscFPTrapPop();
150: PetscMalloc1(n,&perm);
151: for (i=0; i<n; i++) perm[i] = i;
152: PetscSortRealWithPermutation(n,realpart,perm);
153: for (i=0; i<n; i++) {
154: r[i] = realpart[perm[i]];
155: c[i] = imagpart[perm[i]];
156: }
157: PetscFree(perm);
158: #else
159: KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
161: PetscInt n = gmres->it + 1,N = gmres->max_k + 1,i,*perm;
162: PetscScalar *R = gmres->Rsvd,*work = R + N*N,*eigs = work + 5*N,sdummy;
163: PetscBLASInt bn,bN,lwork,idummy,lierr;
166: PetscBLASIntCast(n,&bn);
167: PetscBLASIntCast(N,&bN);
168: PetscBLASIntCast(5*N,&lwork);
169: PetscBLASIntCast(N,&idummy);
170: if (nmax < n) SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_ARG_SIZ,"Not enough room in work space r and c for eigenvalues");
171: *neig = n;
173: if (!n) return(0);
175: /* copy R matrix to work space */
176: PetscMemcpy(R,gmres->hes_origin,N*N*sizeof(PetscScalar));
178: /* compute eigenvalues */
179: PetscFPTrapPush(PETSC_FP_TRAP_OFF);
180: PetscStackCallBLAS("LAPACKgeev",LAPACKgeev_("N","N",&bn,R,&bN,eigs,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,gmres->Dsvd,&lierr));
181: if (lierr) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in LAPACK routine");
182: PetscFPTrapPop();
183: PetscMalloc1(n,&perm);
184: for (i=0; i<n; i++) perm[i] = i;
185: for (i=0; i<n; i++) r[i] = PetscRealPart(eigs[i]);
186: PetscSortRealWithPermutation(n,r,perm);
187: for (i=0; i<n; i++) {
188: r[i] = PetscRealPart(eigs[perm[i]]);
189: c[i] = PetscImaginaryPart(eigs[perm[i]]);
190: }
191: PetscFree(perm);
192: #endif
193: return(0);
194: }
196: #if !defined(PETSC_USE_COMPLEX) && !defined(PETSC_HAVE_ESSL)
199: PetscErrorCode KSPComputeRitz_GMRES(KSP ksp,PetscBool ritz,PetscBool small,PetscInt *nrit,Vec S[],PetscReal *tetar,PetscReal *tetai)
200: {
201: KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
203: PetscInt n = gmres->it + 1,N = gmres->max_k + 1,NbrRitz,nb=0;
204: PetscInt i,j,*perm;
205: PetscReal *H,*Q,*Ht; /* H Hessenberg Matrix and Q matrix of eigenvectors of H*/
206: PetscReal *wr,*wi,*modul; /* Real and imaginary part and modul of the Ritz values*/
207: PetscReal *SR,*work;
208: PetscBLASInt bn,bN,lwork,idummy;
209: PetscScalar *t,sdummy;
212: /* n: size of the Hessenberg matrix */
213: if (gmres->fullcycle) n = N-1;
214: /* NbrRitz: number of (harmonic) Ritz pairs to extract */
215: NbrRitz = PetscMin(*nrit,n);
217: /* Definition of PetscBLASInt for lapack routines*/
218: PetscBLASIntCast(n,&bn);
219: PetscBLASIntCast(N,&bN);
220: PetscBLASIntCast(N,&idummy);
221: PetscBLASIntCast(5*N,&lwork);
222: /* Memory allocation */
223: PetscMalloc1(bN*bN,&H);
224: PetscMalloc1(bn*bn,&Q);
225: PetscMalloc1(lwork,&work);
226: PetscMalloc1(n,&wr);
227: PetscMalloc1(n,&wi);
229: /* copy H matrix to work space */
230: if (gmres->fullcycle) {
231: PetscMemcpy(H,gmres->hes_ritz,bN*bN*sizeof(PetscReal));
232: } else {
233: PetscMemcpy(H,gmres->hes_origin,bN*bN*sizeof(PetscReal));
234: }
236: /* Modify H to compute Harmonic Ritz pairs H = H + H^{-T}*h^2_{m+1,m}e_m*e_m^T */
237: if (!ritz) {
238: /* Transpose the Hessenberg matrix => Ht */
239: PetscMalloc1(bn*bn,&Ht);
240: for (i=0; i<bn; i++) {
241: for (j=0; j<bn; j++) {
242: Ht[i*bn+j] = H[j*bN+i];
243: }
244: }
245: /* Solve the system H^T*t = h^2_{m+1,m}e_m */
246: PetscCalloc1(bn,&t);
247: /* t = h^2_{m+1,m}e_m */
248: if (gmres->fullcycle) {
249: t[bn-1] = PetscSqr(gmres->hes_ritz[(bn-1)*bN+bn]);
250: } else {
251: t[bn-1] = PetscSqr(gmres->hes_origin[(bn-1)*bN+bn]);
252: }
253: /* Call the LAPACK routine dgesv to compute t = H^{-T}*t */
254: #if defined(PETSC_MISSING_LAPACK_GESV)
255: SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"GESV - Lapack routine is unavailable.");
256: #else
257: {
258: PetscBLASInt info;
259: PetscBLASInt nrhs = 1;
260: PetscBLASInt *ipiv;
261: PetscMalloc1(bn,&ipiv);
262: PetscStackCallBLAS("LAPACKgesv",LAPACKgesv_(&bn,&nrhs,Ht,&bn,ipiv,t,&bn,&info));
263: if (info) SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_PLIB,"Error while calling the Lapack routine DGESV");
264: PetscFree(ipiv);
265: PetscFree(Ht);
266: }
267: #endif
268: /* Now form H + H^{-T}*h^2_{m+1,m}e_m*e_m^T */
269: for (i=0; i<bn; i++) H[(bn-1)*bn+i] += t[i];
270: PetscFree(t);
271: }
273: /* Compute (harmonic) Ritz pairs */
274: #if defined(PETSC_MISSING_LAPACK_HSEQR)
275: SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"GEEV - Lapack routine is unavailable\nNot able to provide eigen values.");
276: #else
277: {
278: PetscBLASInt info;
279: PetscFPTrapPush(PETSC_FP_TRAP_OFF);
280: PetscStackCallBLAS("LAPACKgeev",LAPACKgeev_("N","V",&bn,H,&bN,wr,wi,&sdummy,&idummy,Q,&bn,work,&lwork,&info));
281: if (info) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in LAPACK routine");
282: }
283: #endif
284: /* sort the (harmonic) Ritz values */
285: PetscMalloc1(n,&modul);
286: PetscMalloc1(n,&perm);
287: for (i=0; i<n; i++) modul[i] = PetscSqrtReal(wr[i]*wr[i]+wi[i]*wi[i]);
288: for (i=0; i<n; i++) perm[i] = i;
289: PetscSortRealWithPermutation(n,modul,perm);
290: /* count the number of extracted Ritz or Harmonic Ritz pairs (with complex conjugates) */
291: if (small) {
292: while (nb < NbrRitz) {
293: if (!wi[perm[nb]]) nb += 1;
294: else nb += 2;
295: }
296: PetscMalloc(nb*n*sizeof(PetscReal),&SR);
297: for (i=0; i<nb; i++) {
298: tetar[i] = wr[perm[i]];
299: tetai[i] = wi[perm[i]];
300: PetscMemcpy(&SR[i*n],&(Q[perm[i]*bn]),n*sizeof(PetscReal));
301: }
302: } else {
303: while (nb < NbrRitz) {
304: if (wi[perm[n-nb-1]] == 0) nb += 1;
305: else nb += 2;
306: }
307: PetscMalloc(nb*n*sizeof(PetscReal),&SR);
308: for (i=0; i<nb; i++) {
309: tetar[i] = wr[perm[n-nb+i]];
310: tetai[i] = wi[perm[n-nb+i]];
311: PetscMemcpy(&SR[i*n], &(Q[perm[n-nb+i]*bn]), n*sizeof(PetscReal));
312: }
313: }
314: PetscFree(modul);
315: PetscFree(perm);
317: /* Form the Ritz or Harmonic Ritz vectors S=VV*Sr,
318: where the columns of VV correspond to the basis of the Krylov subspace */
319: if (gmres->fullcycle) {
320: for (j=0; j<nb; j++) {
321: VecZeroEntries(S[j]);
322: VecMAXPY(S[j],n,&SR[j*n],gmres->vecb);
323: }
324: } else {
325: for (j=0; j<nb; j++) {
326: VecZeroEntries(S[j]);
327: VecMAXPY(S[j],n,&SR[j*n],&VEC_VV(0));
328: }
329: }
330: *nrit = nb;
331: PetscFree(H);
332: PetscFree(Q);
333: PetscFree(SR);
334: PetscFree(wr);
335: PetscFree(wi);
336: return(0);
337: }
338: #endif