ergo
|
00001 /* Ergo, version 3.2, a program for linear scaling electronic structure 00002 * calculations. 00003 * Copyright (C) 2012 Elias Rudberg, Emanuel H. Rubensson, and Pawel Salek. 00004 * 00005 * This program is free software: you can redistribute it and/or modify 00006 * it under the terms of the GNU General Public License as published by 00007 * the Free Software Foundation, either version 3 of the License, or 00008 * (at your option) any later version. 00009 * 00010 * This program is distributed in the hope that it will be useful, 00011 * but WITHOUT ANY WARRANTY; without even the implied warranty of 00012 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00013 * GNU General Public License for more details. 00014 * 00015 * You should have received a copy of the GNU General Public License 00016 * along with this program. If not, see <http://www.gnu.org/licenses/>. 00017 * 00018 * Primary academic reference: 00019 * KohnâSham Density Functional Theory Electronic Structure Calculations 00020 * with Linearly Scaling Computational Time and Memory Usage, 00021 * Elias Rudberg, Emanuel H. Rubensson, and Pawel Salek, 00022 * J. Chem. Theory Comput. 7, 340 (2011), 00023 * <http://dx.doi.org/10.1021/ct100611z> 00024 * 00025 * For further information about Ergo, see <http://www.ergoscf.org>. 00026 */ 00027 00028 /* This file belongs to the template_lapack part of the Ergo source 00029 * code. The source files in the template_lapack directory are modified 00030 * versions of files originally distributed as CLAPACK, see the 00031 * Copyright/license notice in the file template_lapack/COPYING. 00032 */ 00033 00034 00035 #ifndef TEMPLATE_LAPACK_GGBAK_HEADER 00036 #define TEMPLATE_LAPACK_GGBAK_HEADER 00037 00038 00039 template<class Treal> 00040 int template_lapack_ggbak(const char *job, const char *side, const integer *n, const integer *ilo, 00041 const integer *ihi, const Treal *lscale, const Treal *rscale, const integer *m, 00042 Treal *v, const integer *ldv, integer *info) 00043 { 00044 /* -- LAPACK routine (version 3.0) -- 00045 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 00046 Courant Institute, Argonne National Lab, and Rice University 00047 September 30, 1994 00048 00049 00050 Purpose 00051 ======= 00052 00053 DGGBAK forms the right or left eigenvectors of a real generalized 00054 eigenvalue problem A*x = lambda*B*x, by backward transformation on 00055 the computed eigenvectors of the balanced pair of matrices output by 00056 DGGBAL. 00057 00058 Arguments 00059 ========= 00060 00061 JOB (input) CHARACTER*1 00062 Specifies the type of backward transformation required: 00063 = 'N': do nothing, return immediately; 00064 = 'P': do backward transformation for permutation only; 00065 = 'S': do backward transformation for scaling only; 00066 = 'B': do backward transformations for both permutation and 00067 scaling. 00068 JOB must be the same as the argument JOB supplied to DGGBAL. 00069 00070 SIDE (input) CHARACTER*1 00071 = 'R': V contains right eigenvectors; 00072 = 'L': V contains left eigenvectors. 00073 00074 N (input) INTEGER 00075 The number of rows of the matrix V. N >= 0. 00076 00077 ILO (input) INTEGER 00078 IHI (input) INTEGER 00079 The integers ILO and IHI determined by DGGBAL. 00080 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. 00081 00082 LSCALE (input) DOUBLE PRECISION array, dimension (N) 00083 Details of the permutations and/or scaling factors applied 00084 to the left side of A and B, as returned by DGGBAL. 00085 00086 RSCALE (input) DOUBLE PRECISION array, dimension (N) 00087 Details of the permutations and/or scaling factors applied 00088 to the right side of A and B, as returned by DGGBAL. 00089 00090 M (input) INTEGER 00091 The number of columns of the matrix V. M >= 0. 00092 00093 V (input/output) DOUBLE PRECISION array, dimension (LDV,M) 00094 On entry, the matrix of right or left eigenvectors to be 00095 transformed, as returned by DTGEVC. 00096 On exit, V is overwritten by the transformed eigenvectors. 00097 00098 LDV (input) INTEGER 00099 The leading dimension of the matrix V. LDV >= max(1,N). 00100 00101 INFO (output) INTEGER 00102 = 0: successful exit. 00103 < 0: if INFO = -i, the i-th argument had an illegal value. 00104 00105 Further Details 00106 =============== 00107 00108 See R.C. Ward, Balancing the generalized eigenvalue problem, 00109 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. 00110 00111 ===================================================================== 00112 00113 00114 Test the input parameters 00115 00116 Parameter adjustments */ 00117 /* System generated locals */ 00118 integer v_dim1, v_offset, i__1; 00119 /* Local variables */ 00120 integer i__, k; 00121 logical leftv; 00122 logical rightv; 00123 #define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1] 00124 00125 --lscale; 00126 --rscale; 00127 v_dim1 = *ldv; 00128 v_offset = 1 + v_dim1 * 1; 00129 v -= v_offset; 00130 00131 /* Function Body */ 00132 rightv = template_blas_lsame(side, "R"); 00133 leftv = template_blas_lsame(side, "L"); 00134 00135 *info = 0; 00136 if (! template_blas_lsame(job, "N") && ! template_blas_lsame(job, "P") && ! template_blas_lsame(job, "S") 00137 && ! template_blas_lsame(job, "B")) { 00138 *info = -1; 00139 } else if (! rightv && ! leftv) { 00140 *info = -2; 00141 } else if (*n < 0) { 00142 *info = -3; 00143 } else if (*ilo < 1) { 00144 *info = -4; 00145 } else if (*ihi < *ilo || *ihi > maxMACRO(1,*n)) { 00146 *info = -5; 00147 } else if (*m < 0) { 00148 *info = -6; 00149 } else if (*ldv < maxMACRO(1,*n)) { 00150 *info = -10; 00151 } 00152 if (*info != 0) { 00153 i__1 = -(*info); 00154 template_blas_erbla("GGBAK ", &i__1); 00155 return 0; 00156 } 00157 00158 /* Quick return if possible */ 00159 00160 if (*n == 0) { 00161 return 0; 00162 } 00163 if (*m == 0) { 00164 return 0; 00165 } 00166 if (template_blas_lsame(job, "N")) { 00167 return 0; 00168 } 00169 00170 if (*ilo == *ihi) { 00171 goto L30; 00172 } 00173 00174 /* Backward balance */ 00175 00176 if (template_blas_lsame(job, "S") || template_blas_lsame(job, "B")) { 00177 00178 /* Backward transformation on right eigenvectors */ 00179 00180 if (rightv) { 00181 i__1 = *ihi; 00182 for (i__ = *ilo; i__ <= i__1; ++i__) { 00183 template_blas_scal(m, &rscale[i__], &v_ref(i__, 1), ldv); 00184 /* L10: */ 00185 } 00186 } 00187 00188 /* Backward transformation on left eigenvectors */ 00189 00190 if (leftv) { 00191 i__1 = *ihi; 00192 for (i__ = *ilo; i__ <= i__1; ++i__) { 00193 template_blas_scal(m, &lscale[i__], &v_ref(i__, 1), ldv); 00194 /* L20: */ 00195 } 00196 } 00197 } 00198 00199 /* Backward permutation */ 00200 00201 L30: 00202 if (template_blas_lsame(job, "P") || template_blas_lsame(job, "B")) { 00203 00204 /* Backward permutation on right eigenvectors */ 00205 00206 if (rightv) { 00207 if (*ilo == 1) { 00208 goto L50; 00209 } 00210 00211 for (i__ = *ilo - 1; i__ >= 1; --i__) { 00212 k = (integer) rscale[i__]; 00213 if (k == i__) { 00214 goto L40; 00215 } 00216 template_blas_swap(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv); 00217 L40: 00218 ; 00219 } 00220 00221 L50: 00222 if (*ihi == *n) { 00223 goto L70; 00224 } 00225 i__1 = *n; 00226 for (i__ = *ihi + 1; i__ <= i__1; ++i__) { 00227 k = (integer) rscale[i__]; 00228 if (k == i__) { 00229 goto L60; 00230 } 00231 template_blas_swap(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv); 00232 L60: 00233 ; 00234 } 00235 } 00236 00237 /* Backward permutation on left eigenvectors */ 00238 00239 L70: 00240 if (leftv) { 00241 if (*ilo == 1) { 00242 goto L90; 00243 } 00244 for (i__ = *ilo - 1; i__ >= 1; --i__) { 00245 k = (integer) lscale[i__]; 00246 if (k == i__) { 00247 goto L80; 00248 } 00249 template_blas_swap(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv); 00250 L80: 00251 ; 00252 } 00253 00254 L90: 00255 if (*ihi == *n) { 00256 goto L110; 00257 } 00258 i__1 = *n; 00259 for (i__ = *ihi + 1; i__ <= i__1; ++i__) { 00260 k = (integer) lscale[i__]; 00261 if (k == i__) { 00262 goto L100; 00263 } 00264 template_blas_swap(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv); 00265 L100: 00266 ; 00267 } 00268 } 00269 } 00270 00271 L110: 00272 00273 return 0; 00274 00275 /* End of DGGBAK */ 00276 00277 } /* dggbak_ */ 00278 00279 #undef v_ref 00280 00281 00282 #endif