ergo
template_lapack_ggbak.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_GGBAK_HEADER
36 #define TEMPLATE_LAPACK_GGBAK_HEADER
37 
38 
39 template<class Treal>
40 int template_lapack_ggbak(const char *job, const char *side, const integer *n, const integer *ilo,
41  const integer *ihi, const Treal *lscale, const Treal *rscale, const integer *m,
42  Treal *v, const integer *ldv, integer *info)
43 {
44 /* -- LAPACK routine (version 3.0) --
45  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
46  Courant Institute, Argonne National Lab, and Rice University
47  September 30, 1994
48 
49 
50  Purpose
51  =======
52 
53  DGGBAK forms the right or left eigenvectors of a real generalized
54  eigenvalue problem A*x = lambda*B*x, by backward transformation on
55  the computed eigenvectors of the balanced pair of matrices output by
56  DGGBAL.
57 
58  Arguments
59  =========
60 
61  JOB (input) CHARACTER*1
62  Specifies the type of backward transformation required:
63  = 'N': do nothing, return immediately;
64  = 'P': do backward transformation for permutation only;
65  = 'S': do backward transformation for scaling only;
66  = 'B': do backward transformations for both permutation and
67  scaling.
68  JOB must be the same as the argument JOB supplied to DGGBAL.
69 
70  SIDE (input) CHARACTER*1
71  = 'R': V contains right eigenvectors;
72  = 'L': V contains left eigenvectors.
73 
74  N (input) INTEGER
75  The number of rows of the matrix V. N >= 0.
76 
77  ILO (input) INTEGER
78  IHI (input) INTEGER
79  The integers ILO and IHI determined by DGGBAL.
80  1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
81 
82  LSCALE (input) DOUBLE PRECISION array, dimension (N)
83  Details of the permutations and/or scaling factors applied
84  to the left side of A and B, as returned by DGGBAL.
85 
86  RSCALE (input) DOUBLE PRECISION array, dimension (N)
87  Details of the permutations and/or scaling factors applied
88  to the right side of A and B, as returned by DGGBAL.
89 
90  M (input) INTEGER
91  The number of columns of the matrix V. M >= 0.
92 
93  V (input/output) DOUBLE PRECISION array, dimension (LDV,M)
94  On entry, the matrix of right or left eigenvectors to be
95  transformed, as returned by DTGEVC.
96  On exit, V is overwritten by the transformed eigenvectors.
97 
98  LDV (input) INTEGER
99  The leading dimension of the matrix V. LDV >= max(1,N).
100 
101  INFO (output) INTEGER
102  = 0: successful exit.
103  < 0: if INFO = -i, the i-th argument had an illegal value.
104 
105  Further Details
106  ===============
107 
108  See R.C. Ward, Balancing the generalized eigenvalue problem,
109  SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
110 
111  =====================================================================
112 
113 
114  Test the input parameters
115 
116  Parameter adjustments */
117  /* System generated locals */
118  integer v_dim1, v_offset, i__1;
119  /* Local variables */
120  integer i__, k;
121  logical leftv;
122  logical rightv;
123 #define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1]
124 
125  --lscale;
126  --rscale;
127  v_dim1 = *ldv;
128  v_offset = 1 + v_dim1 * 1;
129  v -= v_offset;
130 
131  /* Function Body */
132  rightv = template_blas_lsame(side, "R");
133  leftv = template_blas_lsame(side, "L");
134 
135  *info = 0;
136  if (! template_blas_lsame(job, "N") && ! template_blas_lsame(job, "P") && ! template_blas_lsame(job, "S")
137  && ! template_blas_lsame(job, "B")) {
138  *info = -1;
139  } else if (! rightv && ! leftv) {
140  *info = -2;
141  } else if (*n < 0) {
142  *info = -3;
143  } else if (*ilo < 1) {
144  *info = -4;
145  } else if (*ihi < *ilo || *ihi > maxMACRO(1,*n)) {
146  *info = -5;
147  } else if (*m < 0) {
148  *info = -6;
149  } else if (*ldv < maxMACRO(1,*n)) {
150  *info = -10;
151  }
152  if (*info != 0) {
153  i__1 = -(*info);
154  template_blas_erbla("GGBAK ", &i__1);
155  return 0;
156  }
157 
158 /* Quick return if possible */
159 
160  if (*n == 0) {
161  return 0;
162  }
163  if (*m == 0) {
164  return 0;
165  }
166  if (template_blas_lsame(job, "N")) {
167  return 0;
168  }
169 
170  if (*ilo == *ihi) {
171  goto L30;
172  }
173 
174 /* Backward balance */
175 
176  if (template_blas_lsame(job, "S") || template_blas_lsame(job, "B")) {
177 
178 /* Backward transformation on right eigenvectors */
179 
180  if (rightv) {
181  i__1 = *ihi;
182  for (i__ = *ilo; i__ <= i__1; ++i__) {
183  template_blas_scal(m, &rscale[i__], &v_ref(i__, 1), ldv);
184 /* L10: */
185  }
186  }
187 
188 /* Backward transformation on left eigenvectors */
189 
190  if (leftv) {
191  i__1 = *ihi;
192  for (i__ = *ilo; i__ <= i__1; ++i__) {
193  template_blas_scal(m, &lscale[i__], &v_ref(i__, 1), ldv);
194 /* L20: */
195  }
196  }
197  }
198 
199 /* Backward permutation */
200 
201 L30:
202  if (template_blas_lsame(job, "P") || template_blas_lsame(job, "B")) {
203 
204 /* Backward permutation on right eigenvectors */
205 
206  if (rightv) {
207  if (*ilo == 1) {
208  goto L50;
209  }
210 
211  for (i__ = *ilo - 1; i__ >= 1; --i__) {
212  k = (integer) rscale[i__];
213  if (k == i__) {
214  goto L40;
215  }
216  template_blas_swap(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
217 L40:
218  ;
219  }
220 
221 L50:
222  if (*ihi == *n) {
223  goto L70;
224  }
225  i__1 = *n;
226  for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
227  k = (integer) rscale[i__];
228  if (k == i__) {
229  goto L60;
230  }
231  template_blas_swap(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
232 L60:
233  ;
234  }
235  }
236 
237 /* Backward permutation on left eigenvectors */
238 
239 L70:
240  if (leftv) {
241  if (*ilo == 1) {
242  goto L90;
243  }
244  for (i__ = *ilo - 1; i__ >= 1; --i__) {
245  k = (integer) lscale[i__];
246  if (k == i__) {
247  goto L80;
248  }
249  template_blas_swap(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
250 L80:
251  ;
252  }
253 
254 L90:
255  if (*ihi == *n) {
256  goto L110;
257  }
258  i__1 = *n;
259  for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
260  k = (integer) lscale[i__];
261  if (k == i__) {
262  goto L100;
263  }
264  template_blas_swap(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
265 L100:
266  ;
267  }
268  }
269  }
270 
271 L110:
272 
273  return 0;
274 
275 /* End of DGGBAK */
276 
277 } /* dggbak_ */
278 
279 #undef v_ref
280 
281 
282 #endif
int template_blas_scal(const integer *n, const Treal *da, Treal *dx, const integer *incx)
Definition: template_blas_scal.h:41
int integer
Definition: template_blas_common.h:38
#define maxMACRO(a, b)
Definition: template_blas_common.h:43
int template_blas_erbla(const char *srname, integer *info)
Definition: template_blas_common.cc:144
int template_blas_swap(const integer *n, Treal *dx, const integer *incx, Treal *dy, const integer *incy)
Definition: template_blas_swap.h:40
bool logical
Definition: template_blas_common.h:39
side
Definition: Matrix.h:73
int template_lapack_ggbak(const char *job, const char *side, const integer *n, const integer *ilo, const integer *ihi, const Treal *lscale, const Treal *rscale, const integer *m, Treal *v, const integer *ldv, integer *info)
Definition: template_lapack_ggbak.h:40
#define v_ref(a_1, a_2)
logical template_blas_lsame(const char *ca, const char *cb)
Definition: template_blas_common.cc:44