ergo
template_lapack_ggbak.h
Go to the documentation of this file.
1 /* Ergo, version 3.8, a program for linear scaling electronic structure
2  * calculations.
3  * Copyright (C) 2019 Elias Rudberg, Emanuel H. Rubensson, Pawel Salek,
4  * and Anastasia Kruchinina.
5  *
6  * This program is free software: you can redistribute it and/or modify
7  * it under the terms of the GNU General Public License as published by
8  * the Free Software Foundation, either version 3 of the License, or
9  * (at your option) any later version.
10  *
11  * This program is distributed in the hope that it will be useful,
12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14  * GNU General Public License for more details.
15  *
16  * You should have received a copy of the GNU General Public License
17  * along with this program. If not, see <http://www.gnu.org/licenses/>.
18  *
19  * Primary academic reference:
20  * Ergo: An open-source program for linear-scaling electronic structure
21  * calculations,
22  * Elias Rudberg, Emanuel H. Rubensson, Pawel Salek, and Anastasia
23  * Kruchinina,
24  * SoftwareX 7, 107 (2018),
25  * <http://dx.doi.org/10.1016/j.softx.2018.03.005>
26  *
27  * For further information about Ergo, see <http://www.ergoscf.org>.
28  */
29 
30  /* This file belongs to the template_lapack part of the Ergo source
31  * code. The source files in the template_lapack directory are modified
32  * versions of files originally distributed as CLAPACK, see the
33  * Copyright/license notice in the file template_lapack/COPYING.
34  */
35 
36 
37 #ifndef TEMPLATE_LAPACK_GGBAK_HEADER
38 #define TEMPLATE_LAPACK_GGBAK_HEADER
39 
40 
41 template<class Treal>
42 int template_lapack_ggbak(const char *job, const char *side, const integer *n, const integer *ilo,
43  const integer *ihi, const Treal *lscale, const Treal *rscale, const integer *m,
44  Treal *v, const integer *ldv, integer *info)
45 {
46 /* -- LAPACK routine (version 3.0) --
47  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
48  Courant Institute, Argonne National Lab, and Rice University
49  September 30, 1994
50 
51 
52  Purpose
53  =======
54 
55  DGGBAK forms the right or left eigenvectors of a real generalized
56  eigenvalue problem A*x = lambda*B*x, by backward transformation on
57  the computed eigenvectors of the balanced pair of matrices output by
58  DGGBAL.
59 
60  Arguments
61  =========
62 
63  JOB (input) CHARACTER*1
64  Specifies the type of backward transformation required:
65  = 'N': do nothing, return immediately;
66  = 'P': do backward transformation for permutation only;
67  = 'S': do backward transformation for scaling only;
68  = 'B': do backward transformations for both permutation and
69  scaling.
70  JOB must be the same as the argument JOB supplied to DGGBAL.
71 
72  SIDE (input) CHARACTER*1
73  = 'R': V contains right eigenvectors;
74  = 'L': V contains left eigenvectors.
75 
76  N (input) INTEGER
77  The number of rows of the matrix V. N >= 0.
78 
79  ILO (input) INTEGER
80  IHI (input) INTEGER
81  The integers ILO and IHI determined by DGGBAL.
82  1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
83 
84  LSCALE (input) DOUBLE PRECISION array, dimension (N)
85  Details of the permutations and/or scaling factors applied
86  to the left side of A and B, as returned by DGGBAL.
87 
88  RSCALE (input) DOUBLE PRECISION array, dimension (N)
89  Details of the permutations and/or scaling factors applied
90  to the right side of A and B, as returned by DGGBAL.
91 
92  M (input) INTEGER
93  The number of columns of the matrix V. M >= 0.
94 
95  V (input/output) DOUBLE PRECISION array, dimension (LDV,M)
96  On entry, the matrix of right or left eigenvectors to be
97  transformed, as returned by DTGEVC.
98  On exit, V is overwritten by the transformed eigenvectors.
99 
100  LDV (input) INTEGER
101  The leading dimension of the matrix V. LDV >= max(1,N).
102 
103  INFO (output) INTEGER
104  = 0: successful exit.
105  < 0: if INFO = -i, the i-th argument had an illegal value.
106 
107  Further Details
108  ===============
109 
110  See R.C. Ward, Balancing the generalized eigenvalue problem,
111  SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
112 
113  =====================================================================
114 
115 
116  Test the input parameters
117 
118  Parameter adjustments */
119  /* System generated locals */
120  integer v_dim1, v_offset, i__1;
121  /* Local variables */
122  integer i__, k;
123  logical leftv;
124  logical rightv;
125 #define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1]
126 
127  --lscale;
128  --rscale;
129  v_dim1 = *ldv;
130  v_offset = 1 + v_dim1 * 1;
131  v -= v_offset;
132 
133  /* Function Body */
134  rightv = template_blas_lsame(side, "R");
135  leftv = template_blas_lsame(side, "L");
136 
137  *info = 0;
138  if (! template_blas_lsame(job, "N") && ! template_blas_lsame(job, "P") && ! template_blas_lsame(job, "S")
139  && ! template_blas_lsame(job, "B")) {
140  *info = -1;
141  } else if (! rightv && ! leftv) {
142  *info = -2;
143  } else if (*n < 0) {
144  *info = -3;
145  } else if (*ilo < 1) {
146  *info = -4;
147  } else if (*ihi < *ilo || *ihi > maxMACRO(1,*n)) {
148  *info = -5;
149  } else if (*m < 0) {
150  *info = -6;
151  } else if (*ldv < maxMACRO(1,*n)) {
152  *info = -10;
153  }
154  if (*info != 0) {
155  i__1 = -(*info);
156  template_blas_erbla("GGBAK ", &i__1);
157  return 0;
158  }
159 
160 /* Quick return if possible */
161 
162  if (*n == 0) {
163  return 0;
164  }
165  if (*m == 0) {
166  return 0;
167  }
168  if (template_blas_lsame(job, "N")) {
169  return 0;
170  }
171 
172  if (*ilo == *ihi) {
173  goto L30;
174  }
175 
176 /* Backward balance */
177 
178  if (template_blas_lsame(job, "S") || template_blas_lsame(job, "B")) {
179 
180 /* Backward transformation on right eigenvectors */
181 
182  if (rightv) {
183  i__1 = *ihi;
184  for (i__ = *ilo; i__ <= i__1; ++i__) {
185  template_blas_scal(m, &rscale[i__], &v_ref(i__, 1), ldv);
186 /* L10: */
187  }
188  }
189 
190 /* Backward transformation on left eigenvectors */
191 
192  if (leftv) {
193  i__1 = *ihi;
194  for (i__ = *ilo; i__ <= i__1; ++i__) {
195  template_blas_scal(m, &lscale[i__], &v_ref(i__, 1), ldv);
196 /* L20: */
197  }
198  }
199  }
200 
201 /* Backward permutation */
202 
203 L30:
204  if (template_blas_lsame(job, "P") || template_blas_lsame(job, "B")) {
205 
206 /* Backward permutation on right eigenvectors */
207 
208  if (rightv) {
209  if (*ilo == 1) {
210  goto L50;
211  }
212 
213  for (i__ = *ilo - 1; i__ >= 1; --i__) {
214  k = (integer) rscale[i__];
215  if (k == i__) {
216  goto L40;
217  }
218  template_blas_swap(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
219 L40:
220  ;
221  }
222 
223 L50:
224  if (*ihi == *n) {
225  goto L70;
226  }
227  i__1 = *n;
228  for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
229  k = (integer) rscale[i__];
230  if (k == i__) {
231  goto L60;
232  }
233  template_blas_swap(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
234 L60:
235  ;
236  }
237  }
238 
239 /* Backward permutation on left eigenvectors */
240 
241 L70:
242  if (leftv) {
243  if (*ilo == 1) {
244  goto L90;
245  }
246  for (i__ = *ilo - 1; i__ >= 1; --i__) {
247  k = (integer) lscale[i__];
248  if (k == i__) {
249  goto L80;
250  }
251  template_blas_swap(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
252 L80:
253  ;
254  }
255 
256 L90:
257  if (*ihi == *n) {
258  goto L110;
259  }
260  i__1 = *n;
261  for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
262  k = (integer) lscale[i__];
263  if (k == i__) {
264  goto L100;
265  }
266  template_blas_swap(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
267 L100:
268  ;
269  }
270  }
271  }
272 
273 L110:
274 
275  return 0;
276 
277 /* End of DGGBAK */
278 
279 } /* dggbak_ */
280 
281 #undef v_ref
282 
283 
284 #endif
template_blas_swap
int template_blas_swap(const integer *n, Treal *dx, const integer *incx, Treal *dy, const integer *incy)
Definition: template_blas_swap.h:42
template_blas_scal
int template_blas_scal(const integer *n, const Treal *da, Treal *dx, const integer *incx)
Definition: template_blas_scal.h:43
mat::side
side
Definition: Matrix.h:75
template_lapack_ggbak
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:42
logical
bool logical
Definition: template_blas_common.h:41
template_blas_erbla
int template_blas_erbla(const char *srname, integer *info)
Definition: template_blas_common.cc:146
template_blas_lsame
logical template_blas_lsame(const char *ca, const char *cb)
Definition: template_blas_common.cc:46
integer
int integer
Definition: template_blas_common.h:40
v_ref
#define v_ref(a_1, a_2)
maxMACRO
#define maxMACRO(a, b)
Definition: template_blas_common.h:45