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_ORG2R_HEADER 00038 #define TEMPLATE_LAPACK_ORG2R_HEADER 00039 00040 00041 template<class Treal> 00042 int template_lapack_org2r(const integer *m, const integer *n, const integer *k, Treal * 00043 a, const integer *lda, const 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 DORG2R generates an m by n real matrix Q with orthonormal columns, 00055 which is defined as the first n columns of a product of k elementary 00056 reflectors of order m 00057 00058 Q = H(1) H(2) . . . H(k) 00059 00060 as returned by DGEQRF. 00061 00062 Arguments 00063 ========= 00064 00065 M (input) INTEGER 00066 The number of rows of the matrix Q. M >= 0. 00067 00068 N (input) INTEGER 00069 The number of columns of the matrix Q. M >= N >= 0. 00070 00071 K (input) INTEGER 00072 The number of elementary reflectors whose product defines the 00073 matrix Q. N >= K >= 0. 00074 00075 A (input/output) DOUBLE PRECISION array, dimension (LDA,N) 00076 On entry, the i-th column must contain the vector which 00077 defines the elementary reflector H(i), for i = 1,2,...,k, as 00078 returned by DGEQRF in the first k columns of its array 00079 argument A. 00080 On exit, the m-by-n matrix Q. 00081 00082 LDA (input) INTEGER 00083 The first dimension of the array A. LDA >= max(1,M). 00084 00085 TAU (input) DOUBLE PRECISION array, dimension (K) 00086 TAU(i) must contain the scalar factor of the elementary 00087 reflector H(i), as returned by DGEQRF. 00088 00089 WORK (workspace) DOUBLE PRECISION array, dimension (N) 00090 00091 INFO (output) INTEGER 00092 = 0: successful exit 00093 < 0: if INFO = -i, the i-th argument has an illegal value 00094 00095 ===================================================================== 00096 00097 00098 Test the input arguments 00099 00100 Parameter adjustments */ 00101 /* Table of constant values */ 00102 integer c__1 = 1; 00103 00104 /* System generated locals */ 00105 integer a_dim1, a_offset, i__1, i__2; 00106 Treal d__1; 00107 /* Local variables */ 00108 integer i__, j, l; 00109 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] 00110 00111 00112 a_dim1 = *lda; 00113 a_offset = 1 + a_dim1 * 1; 00114 a -= a_offset; 00115 --tau; 00116 --work; 00117 00118 /* Function Body */ 00119 *info = 0; 00120 if (*m < 0) { 00121 *info = -1; 00122 } else if (*n < 0 || *n > *m) { 00123 *info = -2; 00124 } else if (*k < 0 || *k > *n) { 00125 *info = -3; 00126 } else if (*lda < maxMACRO(1,*m)) { 00127 *info = -5; 00128 } 00129 if (*info != 0) { 00130 i__1 = -(*info); 00131 template_blas_erbla("ORG2R ", &i__1); 00132 return 0; 00133 } 00134 00135 /* Quick return if possible */ 00136 00137 if (*n <= 0) { 00138 return 0; 00139 } 00140 00141 /* Initialise columns k+1:n to columns of the unit matrix */ 00142 00143 i__1 = *n; 00144 for (j = *k + 1; j <= i__1; ++j) { 00145 i__2 = *m; 00146 for (l = 1; l <= i__2; ++l) { 00147 a_ref(l, j) = 0.; 00148 /* L10: */ 00149 } 00150 a_ref(j, j) = 1.; 00151 /* L20: */ 00152 } 00153 00154 for (i__ = *k; i__ >= 1; --i__) { 00155 00156 /* Apply H(i) to A(i:m,i:n) from the left */ 00157 00158 if (i__ < *n) { 00159 a_ref(i__, i__) = 1.; 00160 i__1 = *m - i__ + 1; 00161 i__2 = *n - i__; 00162 template_lapack_larf("Left", &i__1, &i__2, &a_ref(i__, i__), &c__1, &tau[i__], & 00163 a_ref(i__, i__ + 1), lda, &work[1]); 00164 } 00165 if (i__ < *m) { 00166 i__1 = *m - i__; 00167 d__1 = -tau[i__]; 00168 template_blas_scal(&i__1, &d__1, &a_ref(i__ + 1, i__), &c__1); 00169 } 00170 a_ref(i__, i__) = 1. - tau[i__]; 00171 00172 /* Set A(1:i-1,i) to zero */ 00173 00174 i__1 = i__ - 1; 00175 for (l = 1; l <= i__1; ++l) { 00176 a_ref(l, i__) = 0.; 00177 /* L30: */ 00178 } 00179 /* L40: */ 00180 } 00181 return 0; 00182 00183 /* End of DORG2R */ 00184 00185 } /* dorg2r_ */ 00186 00187 #undef a_ref 00188 00189 00190 #endif