Actual source code: gmreig.c
1: #define PETSCKSP_DLL
3: #include ../src/ksp/ksp/impls/gmres/gmresimpl.h
4: #include petscblaslapack.h
8: PetscErrorCode KSPComputeExtremeSingularValues_GMRES(KSP ksp,PetscReal *emax,PetscReal *emin)
9: {
10: #if defined(PETSC_MISSING_LAPACK_GESVD)
12: /*
13: The Cray math libraries on T3D/T3E, and early versions of Intel Math Kernel Libraries (MKL)
14: for PCs do not seem to have the DGESVD() lapack routines
15: */
16: SETERRQ(PETSC_ERR_SUP,"GESVD - Lapack routine is unavailable\nNot able to provide singular value estimates.");
17: #else
18: KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
20: PetscInt n = gmres->it + 1,i,N = gmres->max_k + 2;
21: PetscBLASInt bn, bN ,lwork, idummy,lierr;
22: PetscScalar *R = gmres->Rsvd,*work = R + N*N,sdummy;
23: PetscReal *realpart = gmres->Dsvd;
26: bn = PetscBLASIntCast(n);
27: bN = PetscBLASIntCast(N);
28: lwork = PetscBLASIntCast(5*N);
29: idummy = PetscBLASIntCast(N);
30: if (!n) {
31: *emax = *emin = 1.0;
32: return(0);
33: }
34: /* copy R matrix to work space */
35: PetscMemcpy(R,gmres->hh_origin,N*N*sizeof(PetscScalar));
37: /* zero below diagonal garbage */
38: for (i=0; i<n; i++) {
39: R[i*N+i+1] = 0.0;
40: }
41:
42: /* compute Singular Values */
43: #if !defined(PETSC_USE_COMPLEX)
44: LAPACKgesvd_("N","N",&bn,&bn,R,&bN,realpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,&lierr);
45: #else
46: LAPACKgesvd_("N","N",&bn,&bn,R,&bN,realpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,realpart+N,&lierr);
47: #endif
48: if (lierr) SETERRQ1(PETSC_ERR_LIB,"Error in SVD Lapack routine %d",(int)lierr);
50: *emin = realpart[n-1];
51: *emax = realpart[0];
52: #endif
53: return(0);
54: }
56: /* ------------------------------------------------------------------------ */
57: /* ESSL has a different calling sequence for dgeev() and zgeev() than standard LAPACK */
60: PetscErrorCode KSPComputeEigenvalues_GMRES(KSP ksp,PetscInt nmax,PetscReal *r,PetscReal *c,PetscInt *neig)
61: {
62: #if defined(PETSC_HAVE_ESSL)
63: KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
65: PetscInt n = gmres->it + 1,N = gmres->max_k + 1,lwork = 5*N;
66: PetscInt i,*perm;
67: PetscScalar *R = gmres->Rsvd;
68: PetscScalar *cwork = R + N*N,sdummy;
69: PetscReal *work,*realpart = gmres->Dsvd ;
70: PetscBLASInt zero = 0,idummy = PetscBLASIntCast(N);
73: if (nmax < n) SETERRQ(PETSC_ERR_ARG_SIZ,"Not enough room in work space r and c for eigenvalues");
74: *neig = n;
76: if (!n) {
77: return(0);
78: }
79: /* copy R matrix to work space */
80: PetscMemcpy(R,gmres->hes_origin,N*N*sizeof(PetscScalar));
82: /* compute eigenvalues */
84: /* for ESSL version need really cwork of length N (complex), 2N
85: (real); already at least 5N of space has been allocated */
87: PetscMalloc(lwork*sizeof(PetscReal),&work);
88: LAPACKgeev_(&zero,R,&idummy,cwork,&sdummy,&idummy,&idummy,&n,work,&lwork);
89: PetscFree(work);
91: /* For now we stick with the convention of storing the real and imaginary
92: components of evalues separately. But is this what we really want? */
93: PetscMalloc(n*sizeof(PetscInt),&perm);
95: #if !defined(PETSC_USE_COMPLEX)
96: for (i=0; i<n; i++) {
97: realpart[i] = cwork[2*i];
98: perm[i] = i;
99: }
100: PetscSortRealWithPermutation(n,realpart,perm);
101: for (i=0; i<n; i++) {
102: r[i] = cwork[2*perm[i]];
103: c[i] = cwork[2*perm[i]+1];
104: }
105: #else
106: for (i=0; i<n; i++) {
107: realpart[i] = PetscRealPart(cwork[i]);
108: perm[i] = i;
109: }
110: PetscSortRealWithPermutation(n,realpart,perm);
111: for (i=0; i<n; i++) {
112: r[i] = PetscRealPart(cwork[perm[i]]);
113: c[i] = PetscImaginaryPart(cwork[perm[i]]);
114: }
115: #endif
116: PetscFree(perm);
117: #elif defined(PETSC_MISSING_LAPACK_GEEV)
119: SETERRQ(PETSC_ERR_SUP,"GEEV - Lapack routine is unavailable\nNot able to provide eigen values.");
120: #elif !defined(PETSC_USE_COMPLEX)
121: KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
123: PetscInt n = gmres->it + 1,N = gmres->max_k + 1,i,*perm;
124: PetscBLASInt bn, bN, lwork, idummy, lierr;
125: PetscScalar *R = gmres->Rsvd,*work = R + N*N;
126: PetscScalar *realpart = gmres->Dsvd,*imagpart = realpart + N,sdummy;
129: bn = PetscBLASIntCast(n);
130: bN = PetscBLASIntCast(N);
131: lwork = PetscBLASIntCast(5*N);
132: idummy = PetscBLASIntCast(N);
133: if (nmax < n) SETERRQ(PETSC_ERR_ARG_SIZ,"Not enough room in work space r and c for eigenvalues");
134: *neig = n;
136: if (!n) {
137: return(0);
138: }
140: /* copy R matrix to work space */
141: PetscMemcpy(R,gmres->hes_origin,N*N*sizeof(PetscScalar));
143: /* compute eigenvalues */
144: LAPACKgeev_("N","N",&bn,R,&bN,realpart,imagpart,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,&lierr);
145: if (lierr) SETERRQ1(PETSC_ERR_LIB,"Error in LAPACK routine %d",(int)lierr);
146: PetscMalloc(n*sizeof(PetscInt),&perm);
147: for (i=0; i<n; i++) { perm[i] = i;}
148: PetscSortRealWithPermutation(n,realpart,perm);
149: for (i=0; i<n; i++) {
150: r[i] = realpart[perm[i]];
151: c[i] = imagpart[perm[i]];
152: }
153: PetscFree(perm);
154: #else
155: KSP_GMRES *gmres = (KSP_GMRES*)ksp->data;
157: PetscInt n = gmres->it + 1,N = gmres->max_k + 1,i,*perm;
158: PetscScalar *R = gmres->Rsvd,*work = R + N*N,*eigs = work + 5*N,sdummy;
159: PetscBLASInt bn,bN,lwork,idummy,lierr;
162: bn = PetscBLASIntCast(n);
163: bN = PetscBLASIntCast(N);
164: lwork = PetscBLASIntCast(5*N);
165: idummy = PetscBLASIntCast(N);
166: if (nmax < n) SETERRQ(PETSC_ERR_ARG_SIZ,"Not enough room in work space r and c for eigenvalues");
167: *neig = n;
169: if (!n) {
170: return(0);
171: }
172: /* copy R matrix to work space */
173: PetscMemcpy(R,gmres->hes_origin,N*N*sizeof(PetscScalar));
175: /* compute eigenvalues */
176: LAPACKgeev_("N","N",&bn,R,&bN,eigs,&sdummy,&idummy,&sdummy,&idummy,work,&lwork,gmres->Dsvd,&lierr);
177: if (lierr) SETERRQ(PETSC_ERR_LIB,"Error in LAPACK routine");
178: PetscMalloc(n*sizeof(PetscInt),&perm);
179: for (i=0; i<n; i++) { perm[i] = i;}
180: for (i=0; i<n; i++) { r[i] = PetscRealPart(eigs[i]);}
181: PetscSortRealWithPermutation(n,r,perm);
182: for (i=0; i<n; i++) {
183: r[i] = PetscRealPart(eigs[perm[i]]);
184: c[i] = PetscImaginaryPart(eigs[perm[i]]);
185: }
186: PetscFree(perm);
187: #endif
188: return(0);
189: }