1: /*
2: BDC - Block-divide and conquer (see description in README file).
4: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5: SLEPc - Scalable Library for Eigenvalue Problem Computations
6: Copyright (c) 2002-2015, Universitat Politecnica de Valencia, Spain
8: This file is part of SLEPc.
10: SLEPc is free software: you can redistribute it and/or modify it under the
11: terms of version 3 of the GNU Lesser General Public License as published by
12: the Free Software Foundation.
14: SLEPc is distributed in the hope that it will be useful, but WITHOUT ANY
15: WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
16: FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for
17: more details.
19: You should have received a copy of the GNU Lesser General Public License
20: along with SLEPc. If not, see <http://www.gnu.org/licenses/>.
21: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
22: */
24: #include <slepc/private/dsimpl.h>
25: #include <slepcblaslapack.h>
27: PetscErrorCode BDC_dlaed3m_(const char *jobz,const char *defl,PetscBLASInt k,PetscBLASInt n, 28: PetscBLASInt n1,PetscReal *d,PetscReal *q,PetscBLASInt ldq, 29: PetscReal rho,PetscReal *dlamda,PetscReal *q2,PetscBLASInt *indx, 30: PetscBLASInt *ctot,PetscReal *w,PetscReal *s,PetscBLASInt *info, 31: PetscBLASInt jobz_len,PetscBLASInt defl_len) 32: {
33: /* -- Routine written in LAPACK version 3.0 style -- */
34: /* *************************************************** */
35: /* Written by */
36: /* Michael Moldaschl and Wilfried Gansterer */
37: /* University of Vienna */
38: /* last modification: March 16, 2014 */
40: /* Small adaptations of original code written by */
41: /* Wilfried Gansterer and Bob Ward, */
42: /* Department of Computer Science, University of Tennessee */
43: /* see http://dx.doi.org/10.1137/S1064827501399432 */
44: /* *************************************************** */
46: /* Purpose */
47: /* ======= */
49: /* DLAED3M finds the roots of the secular equation, as defined by the */
50: /* values in D, W, and RHO, between 1 and K. It makes the */
51: /* appropriate calls to DLAED4 and then updates the eigenvectors by */
52: /* multiplying the matrix of eigenvectors of the pair of eigensystems */
53: /* being combined by the matrix of eigenvectors of the K-by-K system */
54: /* which is solved here. */
56: /* This code makes very mild assumptions about floating point */
57: /* arithmetic. It will work on machines with a guard digit in */
58: /* add/subtract, or on those binary machines without guard digits */
59: /* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
60: /* It could conceivably fail on hexadecimal or decimal machines */
61: /* without guard digits, but we know of none. */
63: /* Arguments */
64: /* ========= */
66: /* JOBZ (input) CHARACTER*1 */
67: /* = 'N': Do not accumulate eigenvectors (not implemented); */
68: /* = 'D': Do accumulate eigenvectors in the divide-and-conquer */
69: /* process. */
71: /* DEFL (input) CHARACTER*1 */
72: /* = '0': No deflation happened in DSRTDF */
73: /* = '1': Some deflation happened in DSRTDF (and therefore some */
74: /* Givens rotations need to be applied to the computed */
75: /* eigenvector matrix Q) */
77: /* K (input) INTEGER */
78: /* The number of terms in the rational function to be solved by */
79: /* DLAED4. 0 <= K <= N. */
81: /* N (input) INTEGER */
82: /* The number of rows and columns in the Q matrix. */
83: /* N >= K (deflation may result in N>K). */
85: /* N1 (input) INTEGER */
86: /* The location of the last eigenvalue in the leading submatrix. */
87: /* min(1,N) <= N1 <= max(1,N-1). */
89: /* D (output) DOUBLE PRECISION array, dimension (N) */
90: /* D(I) contains the updated eigenvalues for */
91: /* 1 <= I <= K. */
93: /* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */
94: /* Initially the first K columns are used as workspace. */
95: /* On output the columns 1 to K contain */
96: /* the updated eigenvectors. */
98: /* LDQ (input) INTEGER */
99: /* The leading dimension of the array Q. LDQ >= max(1,N). */
101: /* RHO (input) DOUBLE PRECISION */
102: /* The value of the parameter in the rank one update equation. */
103: /* RHO >= 0 required. */
105: /* DLAMDA (input/output) DOUBLE PRECISION array, dimension (K) */
106: /* The first K elements of this array contain the old roots */
107: /* of the deflated updating problem. These are the poles */
108: /* of the secular equation. May be changed on output by */
109: /* having lowest order bit set to zero on Cray X-MP, Cray Y-MP, */
110: /* Cray-2, or Cray C-90, as described above. */
112: /* Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N) */
113: /* The first K columns of this matrix contain the non-deflated */
114: /* eigenvectors for the split problem. */
116: /* INDX (input) INTEGER array, dimension (N) */
117: /* The permutation used to arrange the columns of the deflated */
118: /* Q matrix into three groups (see DLAED2). */
119: /* The rows of the eigenvectors found by DLAED4 must be likewise */
120: /* permuted before the matrix multiply can take place. */
122: /* CTOT (input) INTEGER array, dimension (4) */
123: /* A count of the total number of the various types of columns */
124: /* in Q, as described in INDX. The fourth column type is any */
125: /* column which has been deflated. */
127: /* W (input/output) DOUBLE PRECISION array, dimension (K) */
128: /* The first K elements of this array contain the components */
129: /* of the deflation-adjusted updating vector. Destroyed on */
130: /* output. */
132: /* S (workspace) DOUBLE PRECISION array, dimension */
133: /* ( MAX(CTOT(1)+CTOT(2),CTOT(2)+CTOT(3)) + 1 )*K */
134: /* Will contain parts of the eigenvectors of the repaired matrix */
135: /* which will be multiplied by the previously accumulated */
136: /* eigenvectors to update the system. This array is a major */
137: /* source of workspace requirements ! */
139: /* INFO (output) INTEGER */
140: /* = 0: successful exit. */
141: /* < 0: if INFO = -i, the i-th argument had an illegal value. */
142: /* > 0: if INFO = i, eigenpair i was not computed successfully */
144: /* Further Details */
145: /* =============== */
147: /* Based on code written by */
148: /* Wilfried Gansterer and Bob Ward, */
149: /* Department of Computer Science, University of Tennessee */
150: /* Based on the design of the LAPACK code DLAED3 with small modifications */
151: /* (Note that in contrast to the original DLAED3, this routine */
152: /* DOES NOT require that N1 <= N/2) */
154: /* Based on contributions by */
155: /* Jeff Rutter, Computer Science Division, University of California */
156: /* at Berkeley, USA */
157: /* Modified by Francoise Tisseur, University of Tennessee. */
159: /* ===================================================================== */
161: #if defined(SLEPC_MISSING_LAPACK_LAED4) || defined(SLEPC_MISSING_LAPACK_LACPY) || defined(SLEPC_MISSING_LAPACK_LASET)
163: SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"LAED4/LACPY/LASET - Lapack routine is unavailable");
164: #else
165: PetscReal temp, done = 1.0, dzero = 0.0;
166: PetscBLASInt i, j, n2, n12, ii, n23, iq2, i1, one=1;
169: *info = 0;
171: if (k < 0) {
172: *info = -3;
173: } else if (n < k) {
174: *info = -4;
175: } else if (n1 < PetscMin(1,n) || n1 > PetscMax(1,n)) {
176: *info = -5;
177: } else if (ldq < PetscMax(1,n)) {
178: *info = -8;
179: } else if (rho < 0.) {
180: *info = -9;
181: }
182: if (*info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_ARG_WRONG,"Wrong argument %d in DLAED3M",-(*info));
184: /* Quick return if possible */
186: if (k == 0) return(0);
188: /* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
189: /* be computed with high relative accuracy (barring over/underflow). */
190: /* This is a problem on machines without a guard digit in */
191: /* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
192: /* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */
193: /* which on any of these machines zeros out the bottommost */
194: /* bit of DLAMDA(I) if it is 1; this makes the subsequent */
195: /* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */
196: /* occurs. On binary machines with a guard digit (almost all */
197: /* machines) it does not change DLAMDA(I) at all. On hexadecimal */
198: /* and decimal machines with a guard digit, it slightly */
199: /* changes the bottommost bits of DLAMDA(I). It does not account */
200: /* for hexadecimal or decimal machines without guard digits */
201: /* (we know of none). We use a subroutine call to compute */
202: /* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
203: /* this code. */
205: for (i = 0; i < k; ++i) {
206: dlamda[i] = LAPACKlamc3_(&dlamda[i], &dlamda[i]) - dlamda[i];
207: }
209: for (j = 1; j <= k; ++j) {
211: /* ....calling DLAED4 for eigenpair J.... */
213: PetscStackCallBLAS("LAPACKlaed4",LAPACKlaed4_(&k, &j, dlamda, w, &q[(j-1)*ldq], &rho, &d[j-1], info));
214: if (*info) SETERRQ3(PETSC_COMM_SELF,1,"Error in dlaed4, info = %d, failed when computing D(%d)=%g",*info,j,d[j-1]);
216: if (j < k) {
218: /* If the zero finder terminated properly, but the computed */
219: /* eigenvalues are not ordered, issue an error statement */
220: /* but continue computation. */
222: if (dlamda[j-1] >= dlamda[j]) SETERRQ2(PETSC_COMM_SELF,1,"DLAMDA(%d) is greater or equal than DLAMDA(%d)", j, j+1);
223: if (d[j-1] < dlamda[j-1] || d[j-1] > dlamda[j]) SETERRQ6(PETSC_COMM_SELF,1,"DLAMDA(%d) = %g D(%d) = %g DLAMDA(%d) = %g", j, dlamda[j-1], j, d[j-1], j+1, dlamda[j]);
224: }
225: }
227: if (k == 1) goto L110;
229: if (k == 2) {
231: /* permute the components of Q(:,J) (the information returned by DLAED4 */
232: /* necessary to construct the eigenvectors) according to the permutation */
233: /* stored in INDX, resulting from deflation */
235: for (j = 0; j < k; ++j) {
236: w[0] = q[0+j*ldq];
237: w[1] = q[1+j*ldq];
238: ii = indx[0];
239: q[0+j*ldq] = w[ii-1];
240: ii = indx[1];
241: q[1+j*ldq] = w[ii-1];
242: }
243: goto L110;
244: }
246: /* ....K.GE.3.... */
247: /* Compute updated W (used for computing the eigenvectors corresponding */
248: /* to the previously computed eigenvalues). */
250: PetscStackCallBLAS("BLAScopy",BLAScopy_(&k, w, &one, s, &one));
252: /* Initialize W(I) = Q(I,I) */
254: i1 = ldq + 1;
255: PetscStackCallBLAS("BLAScopy",BLAScopy_(&k, q, &i1, w, &one));
256: for (j = 0; j < k; ++j) {
257: for (i = 0; i < j; ++i) {
258: w[i] *= q[i+j*ldq] / (dlamda[i] - dlamda[j]);
259: }
260: for (i = j + 1; i < k; ++i) {
261: w[i] *= q[i+j*ldq] / (dlamda[i] - dlamda[j]);
262: }
263: }
264: for (i = 0; i < k; ++i) {
265: temp = PetscSqrtReal(-w[i]);
266: if (temp<0) temp = -temp;
267: w[i] = (s[i] >= 0) ? temp : -temp;
268: }
270: /* Compute eigenvectors of the modified rank-1 modification (using the */
271: /* vector W). */
273: for (j = 0; j < k; ++j) {
274: for (i = 0; i < k; ++i) {
275: s[i] = w[i] / q[i+j*ldq];
276: }
277: temp = BLASnrm2_(&k, s, &one);
278: for (i = 0; i < k; ++i) {
280: /* apply the permutation resulting from deflation as stored */
281: /* in INDX */
283: ii = indx[i];
284: q[i+j*ldq] = s[ii-1] / temp;
285: }
286: }
288: /* ************************************************************************** */
290: /* ....updating the eigenvectors.... */
292: L110:294: n2 = n - n1;
295: n12 = ctot[0] + ctot[1];
296: n23 = ctot[1] + ctot[2];
297: if (*(unsigned char *)jobz == 'D') {
299: /* Compute the updated eigenvectors. (NOTE that every call of */
300: /* DGEMM requires three DISTINCT arrays) */
302: /* copy Q( CTOT(1)+1:K,1:K ) to S */
304: PetscStackCallBLAS("LAPACKlacpy",LAPACKlacpy_("A", &n23, &k, &q[ctot[0]], &ldq, s, &n23));
305: iq2 = n1 * n12 + 1;
307: if (n23 != 0) {
309: /* multiply the second part of Q2 (the eigenvectors of the */
310: /* lower block) with S and write the result into the lower part of */
311: /* Q, i.e., Q( N1+1:N,1:K ) */
313: PetscStackCallBLAS("BLASgemm",BLASgemm_("N", "N", &n2, &k, &n23, &done,
314: &q2[iq2-1], &n2, s, &n23, &dzero, &q[n1], &ldq));
315: } else {
316: PetscStackCallBLAS("LAPACKlaset",LAPACKlaset_("A", &n2, &k, &dzero, &dzero, &q[n1], &ldq));
317: }
319: /* copy Q( 1:CTOT(1)+CTOT(2),1:K ) to S */
321: PetscStackCallBLAS("LAPACKlacpy",LAPACKlacpy_("A", &n12, &k, q, &ldq, s, &n12));
323: if (n12 != 0) {
325: /* multiply the first part of Q2 (the eigenvectors of the */
326: /* upper block) with S and write the result into the upper part of */
327: /* Q, i.e., Q( 1:N1,1:K ) */
329: PetscStackCallBLAS("BLASgemm",BLASgemm_("N", "N", &n1, &k, &n12, &done,
330: q2, &n1, s, &n12, &dzero, q, &ldq));
331: } else {
332: PetscStackCallBLAS("LAPACKlaset",LAPACKlaset_("A", &n1, &k, &dzero, &dzero, q, &ldq));
333: }
334: }
335: return(0);
336: #endif
337: }