00001 /* Ergo, version 3.7, a program for linear scaling electronic structure 00002 * calculations. 00003 * Copyright (C) 2018 Elias Rudberg, Emanuel H. Rubensson, Pawel Salek, 00004 * and Anastasia Kruchinina. 00005 * 00006 * This program is free software: you can redistribute it and/or modify 00007 * it under the terms of the GNU General Public License as published by 00008 * the Free Software Foundation, either version 3 of the License, or 00009 * (at your option) any later version. 00010 * 00011 * This program is distributed in the hope that it will be useful, 00012 * but WITHOUT ANY WARRANTY; without even the implied warranty of 00013 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00014 * GNU General Public License for more details. 00015 * 00016 * You should have received a copy of the GNU General Public License 00017 * along with this program. If not, see <http://www.gnu.org/licenses/>. 00018 * 00019 * Primary academic reference: 00020 * Ergo: An open-source program for linear-scaling electronic structure 00021 * calculations, 00022 * Elias Rudberg, Emanuel H. Rubensson, Pawel Salek, and Anastasia 00023 * Kruchinina, 00024 * SoftwareX 7, 107 (2018), 00025 * <http://dx.doi.org/10.1016/j.softx.2018.03.005> 00026 * 00027 * For further information about Ergo, see <http://www.ergoscf.org>. 00028 */ 00029 00030 /* This file belongs to the template_lapack part of the Ergo source 00031 * code. The source files in the template_lapack directory are modified 00032 * versions of files originally distributed as CLAPACK, see the 00033 * Copyright/license notice in the file template_lapack/COPYING. 00034 */ 00035 00036 00037 #ifndef TEMPLATE_LAPACK_GEQR2_HEADER 00038 #define TEMPLATE_LAPACK_GEQR2_HEADER 00039 00040 00041 template<class Treal> 00042 int template_lapack_geqr2(const integer *m, const integer *n, Treal *a, const integer * 00043 lda, Treal *tau, Treal *work, integer *info) 00044 { 00045 /* -- LAPACK routine (version 3.0) -- 00046 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 00047 Courant Institute, Argonne National Lab, and Rice University 00048 February 29, 1992 00049 00050 00051 Purpose 00052 ======= 00053 00054 DGEQR2 computes a QR factorization of a real m by n matrix A: 00055 A = Q * R. 00056 00057 Arguments 00058 ========= 00059 00060 M (input) INTEGER 00061 The number of rows of the matrix A. M >= 0. 00062 00063 N (input) INTEGER 00064 The number of columns of the matrix A. N >= 0. 00065 00066 A (input/output) DOUBLE PRECISION array, dimension (LDA,N) 00067 On entry, the m by n matrix A. 00068 On exit, the elements on and above the diagonal of the array 00069 contain the min(m,n) by n upper trapezoidal matrix R (R is 00070 upper triangular if m >= n); the elements below the diagonal, 00071 with the array TAU, represent the orthogonal matrix Q as a 00072 product of elementary reflectors (see Further Details). 00073 00074 LDA (input) INTEGER 00075 The leading dimension of the array A. LDA >= max(1,M). 00076 00077 TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) 00078 The scalar factors of the elementary reflectors (see Further 00079 Details). 00080 00081 WORK (workspace) DOUBLE PRECISION array, dimension (N) 00082 00083 INFO (output) INTEGER 00084 = 0: successful exit 00085 < 0: if INFO = -i, the i-th argument had an illegal value 00086 00087 Further Details 00088 =============== 00089 00090 The matrix Q is represented as a product of elementary reflectors 00091 00092 Q = H(1) H(2) . . . H(k), where k = min(m,n). 00093 00094 Each H(i) has the form 00095 00096 H(i) = I - tau * v * v' 00097 00098 where tau is a real scalar, and v is a real vector with 00099 v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), 00100 and tau in TAU(i). 00101 00102 ===================================================================== 00103 00104 00105 Test the input arguments 00106 00107 Parameter adjustments */ 00108 /* Table of constant values */ 00109 integer c__1 = 1; 00110 00111 /* System generated locals */ 00112 integer a_dim1, a_offset, i__1, i__2, i__3; 00113 /* Local variables */ 00114 integer i__, k; 00115 Treal aii; 00116 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] 00117 00118 00119 a_dim1 = *lda; 00120 a_offset = 1 + a_dim1 * 1; 00121 a -= a_offset; 00122 --tau; 00123 --work; 00124 00125 /* Function Body */ 00126 *info = 0; 00127 if (*m < 0) { 00128 *info = -1; 00129 } else if (*n < 0) { 00130 *info = -2; 00131 } else if (*lda < maxMACRO(1,*m)) { 00132 *info = -4; 00133 } 00134 if (*info != 0) { 00135 i__1 = -(*info); 00136 template_blas_erbla("GEQR2 ", &i__1); 00137 return 0; 00138 } 00139 00140 k = minMACRO(*m,*n); 00141 00142 i__1 = k; 00143 for (i__ = 1; i__ <= i__1; ++i__) { 00144 00145 /* Generate elementary reflector H(i) to annihilate A(i+1:m,i) 00146 00147 Computing MIN */ 00148 i__2 = i__ + 1; 00149 i__3 = *m - i__ + 1; 00150 template_lapack_larfg(&i__3, &a_ref(i__, i__), &a_ref(minMACRO(i__2,*m), i__), &c__1, & 00151 tau[i__]); 00152 if (i__ < *n) { 00153 00154 /* Apply H(i) to A(i:m,i+1:n) from the left */ 00155 00156 aii = a_ref(i__, i__); 00157 a_ref(i__, i__) = 1.; 00158 i__2 = *m - i__ + 1; 00159 i__3 = *n - i__; 00160 template_lapack_larf("Left", &i__2, &i__3, &a_ref(i__, i__), &c__1, &tau[i__], & 00161 a_ref(i__, i__ + 1), lda, &work[1]); 00162 a_ref(i__, i__) = aii; 00163 } 00164 /* L10: */ 00165 } 00166 return 0; 00167 00168 /* End of DGEQR2 */ 00169 00170 } /* dgeqr2_ */ 00171 00172 #undef a_ref 00173 00174 00175 #endif