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_ORG2L_HEADER 00038 #define TEMPLATE_LAPACK_ORG2L_HEADER 00039 00040 00041 template<class Treal> 00042 int template_lapack_org2l(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 DORG2L generates an m by n real matrix Q with orthonormal columns, 00055 which is defined as the last n columns of a product of k elementary 00056 reflectors of order m 00057 00058 Q = H(k) . . . H(2) H(1) 00059 00060 as returned by DGEQLF. 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 (n-k+i)-th column must contain the vector which 00077 defines the elementary reflector H(i), for i = 1,2,...,k, as 00078 returned by DGEQLF in the last 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 DGEQLF. 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, i__3; 00106 Treal d__1; 00107 /* Local variables */ 00108 integer i__, j, l; 00109 integer ii; 00110 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] 00111 00112 00113 a_dim1 = *lda; 00114 a_offset = 1 + a_dim1 * 1; 00115 a -= a_offset; 00116 --tau; 00117 --work; 00118 00119 /* Function Body */ 00120 *info = 0; 00121 if (*m < 0) { 00122 *info = -1; 00123 } else if (*n < 0 || *n > *m) { 00124 *info = -2; 00125 } else if (*k < 0 || *k > *n) { 00126 *info = -3; 00127 } else if (*lda < maxMACRO(1,*m)) { 00128 *info = -5; 00129 } 00130 if (*info != 0) { 00131 i__1 = -(*info); 00132 template_blas_erbla("ORG2L ", &i__1); 00133 return 0; 00134 } 00135 00136 /* Quick return if possible */ 00137 00138 if (*n <= 0) { 00139 return 0; 00140 } 00141 00142 /* Initialise columns 1:n-k to columns of the unit matrix */ 00143 00144 i__1 = *n - *k; 00145 for (j = 1; j <= i__1; ++j) { 00146 i__2 = *m; 00147 for (l = 1; l <= i__2; ++l) { 00148 a_ref(l, j) = 0.; 00149 /* L10: */ 00150 } 00151 a_ref(*m - *n + j, j) = 1.; 00152 /* L20: */ 00153 } 00154 00155 i__1 = *k; 00156 for (i__ = 1; i__ <= i__1; ++i__) { 00157 ii = *n - *k + i__; 00158 00159 /* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */ 00160 00161 a_ref(*m - *n + ii, ii) = 1.; 00162 i__2 = *m - *n + ii; 00163 i__3 = ii - 1; 00164 template_lapack_larf("Left", &i__2, &i__3, &a_ref(1, ii), &c__1, &tau[i__], &a[ 00165 a_offset], lda, &work[1]); 00166 i__2 = *m - *n + ii - 1; 00167 d__1 = -tau[i__]; 00168 template_blas_scal(&i__2, &d__1, &a_ref(1, ii), &c__1); 00169 a_ref(*m - *n + ii, ii) = 1. - tau[i__]; 00170 00171 /* Set A(m-k+i+1:m,n-k+i) to zero */ 00172 00173 i__2 = *m; 00174 for (l = *m - *n + ii + 1; l <= i__2; ++l) { 00175 a_ref(l, ii) = 0.; 00176 /* L30: */ 00177 } 00178 /* L40: */ 00179 } 00180 return 0; 00181 00182 /* End of DORG2L */ 00183 00184 } /* dorg2l_ */ 00185 00186 #undef a_ref 00187 00188 00189 #endif