ergo
template_lapack_larrb.h
Go to the documentation of this file.
1 /* Ergo, version 3.4, a program for linear scaling electronic structure
2  * calculations.
3  * Copyright (C) 2014 Elias Rudberg, Emanuel H. Rubensson, and Pawel Salek.
4  *
5  * This program is free software: you can redistribute it and/or modify
6  * it under the terms of the GNU General Public License as published by
7  * the Free Software Foundation, either version 3 of the License, or
8  * (at your option) any later version.
9  *
10  * This program is distributed in the hope that it will be useful,
11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13  * GNU General Public License for more details.
14  *
15  * You should have received a copy of the GNU General Public License
16  * along with this program. If not, see <http://www.gnu.org/licenses/>.
17  *
18  * Primary academic reference:
19  * Kohn−Sham Density Functional Theory Electronic Structure Calculations
20  * with Linearly Scaling Computational Time and Memory Usage,
21  * Elias Rudberg, Emanuel H. Rubensson, and Pawel Salek,
22  * J. Chem. Theory Comput. 7, 340 (2011),
23  * <http://dx.doi.org/10.1021/ct100611z>
24  *
25  * For further information about Ergo, see <http://www.ergoscf.org>.
26  */
27 
28  /* This file belongs to the template_lapack part of the Ergo source
29  * code. The source files in the template_lapack directory are modified
30  * versions of files originally distributed as CLAPACK, see the
31  * Copyright/license notice in the file template_lapack/COPYING.
32  */
33 
34 
35 #ifndef TEMPLATE_LAPACK_LARRB_HEADER
36 #define TEMPLATE_LAPACK_LARRB_HEADER
37 
38 
39 #include "template_lapack_laneg.h"
40 
41 
42 template<class Treal>
43 int template_lapack_larrb(integer *n, Treal *d__, Treal *lld,
44  integer *ifirst, integer *ilast, Treal *rtol1, Treal *rtol2,
45  integer *offset, Treal *w, Treal *wgap, Treal *werr,
46  Treal *work, integer *iwork, Treal *pivmin, Treal *
47  spdiam, integer *twist, integer *info)
48 {
49  /* System generated locals */
50  integer i__1;
51  Treal d__1, d__2;
52 
53  /* Local variables */
54  integer i__, k, r__, i1, ii, ip;
55  Treal gap, mid, tmp, back, lgap, rgap, left;
56  integer iter, nint, prev, next;
57  Treal cvrgd, right, width;
58  integer negcnt;
59  Treal mnwdth;
60  integer olnint, maxitr;
61 
62 
63 /* -- LAPACK auxiliary routine (version 3.2) -- */
64 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
65 /* November 2006 */
66 
67 /* .. Scalar Arguments .. */
68 /* .. */
69 /* .. Array Arguments .. */
70 /* .. */
71 
72 /* Purpose */
73 /* ======= */
74 
75 /* Given the relatively robust representation(RRR) L D L^T, DLARRB */
76 /* does "limited" bisection to refine the eigenvalues of L D L^T, */
77 /* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */
78 /* guesses for these eigenvalues are input in W, the corresponding estimate */
79 /* of the error in these guesses and their gaps are input in WERR */
80 /* and WGAP, respectively. During bisection, intervals */
81 /* [left, right] are maintained by storing their mid-points and */
82 /* semi-widths in the arrays W and WERR respectively. */
83 
84 /* Arguments */
85 /* ========= */
86 
87 /* N (input) INTEGER */
88 /* The order of the matrix. */
89 
90 /* D (input) DOUBLE PRECISION array, dimension (N) */
91 /* The N diagonal elements of the diagonal matrix D. */
92 
93 /* LLD (input) DOUBLE PRECISION array, dimension (N-1) */
94 /* The (N-1) elements L(i)*L(i)*D(i). */
95 
96 /* IFIRST (input) INTEGER */
97 /* The index of the first eigenvalue to be computed. */
98 
99 /* ILAST (input) INTEGER */
100 /* The index of the last eigenvalue to be computed. */
101 
102 /* RTOL1 (input) DOUBLE PRECISION */
103 /* RTOL2 (input) DOUBLE PRECISION */
104 /* Tolerance for the convergence of the bisection intervals. */
105 /* An interval [LEFT,RIGHT] has converged if */
106 /* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
107 /* where GAP is the (estimated) distance to the nearest */
108 /* eigenvalue. */
109 
110 /* OFFSET (input) INTEGER */
111 /* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET */
112 /* through ILAST-OFFSET elements of these arrays are to be used. */
113 
114 /* W (input/output) DOUBLE PRECISION array, dimension (N) */
115 /* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */
116 /* estimates of the eigenvalues of L D L^T indexed IFIRST throug */
117 /* ILAST. */
118 /* On output, these estimates are refined. */
119 
120 /* WGAP (input/output) DOUBLE PRECISION array, dimension (N-1) */
121 /* On input, the (estimated) gaps between consecutive */
122 /* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between */
123 /* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST */
124 /* then WGAP(IFIRST-OFFSET) must be set to ZERO. */
125 /* On output, these gaps are refined. */
126 
127 /* WERR (input/output) DOUBLE PRECISION array, dimension (N) */
128 /* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */
129 /* the errors in the estimates of the corresponding elements in W. */
130 /* On output, these errors are refined. */
131 
132 /* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
133 /* Workspace. */
134 
135 /* IWORK (workspace) INTEGER array, dimension (2*N) */
136 /* Workspace. */
137 
138 /* PIVMIN (input) DOUBLE PRECISION */
139 /* The minimum pivot in the Sturm sequence. */
140 
141 /* SPDIAM (input) DOUBLE PRECISION */
142 /* The spectral diameter of the matrix. */
143 
144 /* TWIST (input) INTEGER */
145 /* The twist index for the twisted factorization that is used */
146 /* for the negcount. */
147 /* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T */
148 /* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T */
149 /* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r) */
150 
151 /* INFO (output) INTEGER */
152 /* Error flag. */
153 
154 /* Further Details */
155 /* =============== */
156 
157 /* Based on contributions by */
158 /* Beresford Parlett, University of California, Berkeley, USA */
159 /* Jim Demmel, University of California, Berkeley, USA */
160 /* Inderjit Dhillon, University of Texas, Austin, USA */
161 /* Osni Marques, LBNL/NERSC, USA */
162 /* Christof Voemel, University of California, Berkeley, USA */
163 
164 /* ===================================================================== */
165 
166 /* .. Parameters .. */
167 /* .. */
168 /* .. Local Scalars .. */
169 /* .. */
170 /* .. External Functions .. */
171 
172 /* .. */
173 /* .. Intrinsic Functions .. */
174 /* .. */
175 /* .. Executable Statements .. */
176 
177  /* Parameter adjustments */
178  --iwork;
179  --work;
180  --werr;
181  --wgap;
182  --w;
183  --lld;
184  --d__;
185 
186  /* Function Body */
187  *info = 0;
188 
189  maxitr = (integer) ((template_blas_log(*spdiam + *pivmin) - template_blas_log(*pivmin)) / template_blas_log(2.)) +
190  2;
191  mnwdth = *pivmin * 2.;
192 
193  r__ = *twist;
194  if (r__ < 1 || r__ > *n) {
195  r__ = *n;
196  }
197 
198 /* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */
199 /* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */
200 /* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */
201 /* for an unconverged interval is set to the index of the next unconverged */
202 /* interval, and is -1 or 0 for a converged interval. Thus a linked */
203 /* list of unconverged intervals is set up. */
204 
205  i1 = *ifirst;
206 /* The number of unconverged intervals */
207  nint = 0;
208 /* The last unconverged interval found */
209  prev = 0;
210  rgap = wgap[i1 - *offset];
211  i__1 = *ilast;
212  for (i__ = i1; i__ <= i__1; ++i__) {
213  k = i__ << 1;
214  ii = i__ - *offset;
215  left = w[ii] - werr[ii];
216  right = w[ii] + werr[ii];
217  lgap = rgap;
218  rgap = wgap[ii];
219  gap = minMACRO(lgap,rgap);
220 /* Make sure that [LEFT,RIGHT] contains the desired eigenvalue */
221 /* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT */
222 
223 /* Do while( NEGCNT(LEFT).GT.I-1 ) */
224 
225  back = werr[ii];
226 L20:
227  negcnt = template_lapack_laneg(n, &d__[1], &lld[1], &left, pivmin, &r__);
228  if (negcnt > i__ - 1) {
229  left -= back;
230  back *= 2.;
231  goto L20;
232  }
233 
234 /* Do while( NEGCNT(RIGHT).LT.I ) */
235 /* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT */
236 
237  back = werr[ii];
238 L50:
239  negcnt = template_lapack_laneg(n, &d__[1], &lld[1], &right, pivmin, &r__);
240  if (negcnt < i__) {
241  right += back;
242  back *= 2.;
243  goto L50;
244  }
245  width = (d__1 = left - right, absMACRO(d__1)) * .5;
246 /* Computing MAX */
247  d__1 = absMACRO(left), d__2 = absMACRO(right);
248  tmp = maxMACRO(d__1,d__2);
249 /* Computing MAX */
250  d__1 = *rtol1 * gap, d__2 = *rtol2 * tmp;
251  cvrgd = maxMACRO(d__1,d__2);
252  if (width <= cvrgd || width <= mnwdth) {
253 /* This interval has already converged and does not need refinement. */
254 /* (Note that the gaps might change through refining the */
255 /* eigenvalues, however, they can only get bigger.) */
256 /* Remove it from the list. */
257  iwork[k - 1] = -1;
258 /* Make sure that I1 always points to the first unconverged interval */
259  if (i__ == i1 && i__ < *ilast) {
260  i1 = i__ + 1;
261  }
262  if (prev >= i1 && i__ <= *ilast) {
263  iwork[(prev << 1) - 1] = i__ + 1;
264  }
265  } else {
266 /* unconverged interval found */
267  prev = i__;
268  ++nint;
269  iwork[k - 1] = i__ + 1;
270  iwork[k] = negcnt;
271  }
272  work[k - 1] = left;
273  work[k] = right;
274 /* L75: */
275  }
276 
277 /* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */
278 /* and while (ITER.LT.MAXITR) */
279 
280  iter = 0;
281 L80:
282  prev = i1 - 1;
283  i__ = i1;
284  olnint = nint;
285  i__1 = olnint;
286  for (ip = 1; ip <= i__1; ++ip) {
287  k = i__ << 1;
288  ii = i__ - *offset;
289  rgap = wgap[ii];
290  lgap = rgap;
291  if (ii > 1) {
292  lgap = wgap[ii - 1];
293  }
294  gap = minMACRO(lgap,rgap);
295  next = iwork[k - 1];
296  left = work[k - 1];
297  right = work[k];
298  mid = (left + right) * .5;
299 /* semiwidth of interval */
300  width = right - mid;
301 /* Computing MAX */
302  d__1 = absMACRO(left), d__2 = absMACRO(right);
303  tmp = maxMACRO(d__1,d__2);
304 /* Computing MAX */
305  d__1 = *rtol1 * gap, d__2 = *rtol2 * tmp;
306  cvrgd = maxMACRO(d__1,d__2);
307  if (width <= cvrgd || width <= mnwdth || iter == maxitr) {
308 /* reduce number of unconverged intervals */
309  --nint;
310 /* Mark interval as converged. */
311  iwork[k - 1] = 0;
312  if (i1 == i__) {
313  i1 = next;
314  } else {
315 /* Prev holds the last unconverged interval previously examined */
316  if (prev >= i1) {
317  iwork[(prev << 1) - 1] = next;
318  }
319  }
320  i__ = next;
321  goto L100;
322  }
323  prev = i__;
324 
325 /* Perform one bisection step */
326 
327  negcnt = template_lapack_laneg(n, &d__[1], &lld[1], &mid, pivmin, &r__);
328  if (negcnt <= i__ - 1) {
329  work[k - 1] = mid;
330  } else {
331  work[k] = mid;
332  }
333  i__ = next;
334 L100:
335  ;
336  }
337  ++iter;
338 /* do another loop if there are still unconverged intervals */
339 /* However, in the last iteration, all intervals are accepted */
340 /* since this is the best we can do. */
341  if (nint > 0 && iter <= maxitr) {
342  goto L80;
343  }
344 
345 
346 /* At this point, all the intervals have converged */
347  i__1 = *ilast;
348  for (i__ = *ifirst; i__ <= i__1; ++i__) {
349  k = i__ << 1;
350  ii = i__ - *offset;
351 /* All intervals marked by '0' have been refined. */
352  if (iwork[k - 1] == 0) {
353  w[ii] = (work[k - 1] + work[k]) * .5;
354  werr[ii] = work[k] - w[ii];
355  }
356 /* L110: */
357  }
358 
359  i__1 = *ilast;
360  for (i__ = *ifirst + 1; i__ <= i__1; ++i__) {
361  k = i__ << 1;
362  ii = i__ - *offset;
363 /* Computing MAX */
364  d__1 = 0., d__2 = w[ii] - werr[ii] - w[ii - 1] - werr[ii - 1];
365  wgap[ii - 1] = maxMACRO(d__1,d__2);
366 /* L111: */
367  }
368  return 0;
369 
370 /* End of DLARRB */
371 
372 } /* dlarrb_ */
373 
374 #endif
#define absMACRO(x)
Definition: template_blas_common.h:45
Definition: Matrix.h:73
int template_lapack_larrb(integer *n, Treal *d__, Treal *lld, integer *ifirst, integer *ilast, Treal *rtol1, Treal *rtol2, integer *offset, Treal *w, Treal *wgap, Treal *werr, Treal *work, integer *iwork, Treal *pivmin, Treal *spdiam, integer *twist, integer *info)
Definition: template_lapack_larrb.h:43
int integer
Definition: template_blas_common.h:38
#define maxMACRO(a, b)
Definition: template_blas_common.h:43
int template_lapack_laneg(integer *n, Treal *d__, Treal *lld, Treal *sigma, Treal *pivmin, integer *r__)
Definition: template_lapack_laneg.h:43
#define minMACRO(a, b)
Definition: template_blas_common.h:44
Treal template_blas_log(Treal x)
Definition: Matrix.h:73