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_LARF_HEADER 00038 #define TEMPLATE_LAPACK_LARF_HEADER 00039 00040 00041 template<class Treal> 00042 int template_lapack_larf(const char *side, const integer *m, const integer *n, const Treal *v, 00043 const integer *incv, const Treal *tau, Treal *c__, const integer *ldc, 00044 Treal *work) 00045 { 00046 /* -- LAPACK auxiliary routine (version 3.0) -- 00047 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 00048 Courant Institute, Argonne National Lab, and Rice University 00049 February 29, 1992 00050 00051 00052 Purpose 00053 ======= 00054 00055 DLARF applies a real elementary reflector H to a real m by n matrix 00056 C, from either the left or the right. H is represented in the form 00057 00058 H = I - tau * v * v' 00059 00060 where tau is a real scalar and v is a real vector. 00061 00062 If tau = 0, then H is taken to be the unit matrix. 00063 00064 Arguments 00065 ========= 00066 00067 SIDE (input) CHARACTER*1 00068 = 'L': form H * C 00069 = 'R': form C * H 00070 00071 M (input) INTEGER 00072 The number of rows of the matrix C. 00073 00074 N (input) INTEGER 00075 The number of columns of the matrix C. 00076 00077 V (input) DOUBLE PRECISION array, dimension 00078 (1 + (M-1)*abs(INCV)) if SIDE = 'L' 00079 or (1 + (N-1)*abs(INCV)) if SIDE = 'R' 00080 The vector v in the representation of H. V is not used if 00081 TAU = 0. 00082 00083 INCV (input) INTEGER 00084 The increment between elements of v. INCV <> 0. 00085 00086 TAU (input) DOUBLE PRECISION 00087 The value tau in the representation of H. 00088 00089 C (input/output) DOUBLE PRECISION array, dimension (LDC,N) 00090 On entry, the m by n matrix C. 00091 On exit, C is overwritten by the matrix H * C if SIDE = 'L', 00092 or C * H if SIDE = 'R'. 00093 00094 LDC (input) INTEGER 00095 The leading dimension of the array C. LDC >= max(1,M). 00096 00097 WORK (workspace) DOUBLE PRECISION array, dimension 00098 (N) if SIDE = 'L' 00099 or (M) if SIDE = 'R' 00100 00101 ===================================================================== 00102 00103 00104 Parameter adjustments */ 00105 /* Table of constant values */ 00106 Treal c_b4 = 1.; 00107 Treal c_b5 = 0.; 00108 integer c__1 = 1; 00109 00110 /* System generated locals */ 00111 integer c_dim1, c_offset; 00112 Treal d__1; 00113 00114 00115 --v; 00116 c_dim1 = *ldc; 00117 c_offset = 1 + c_dim1 * 1; 00118 c__ -= c_offset; 00119 --work; 00120 00121 /* Function Body */ 00122 if (template_blas_lsame(side, "L")) { 00123 00124 /* Form H * C */ 00125 00126 if (*tau != 0.) { 00127 00128 /* w := C' * v */ 00129 00130 template_blas_gemv("Transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1], incv, 00131 &c_b5, &work[1], &c__1); 00132 00133 /* C := C - v * w' */ 00134 00135 d__1 = -(*tau); 00136 template_blas_ger(m, n, &d__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], 00137 ldc); 00138 } 00139 } else { 00140 00141 /* Form C * H */ 00142 00143 if (*tau != 0.) { 00144 00145 /* w := C * v */ 00146 00147 template_blas_gemv("No transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1], 00148 incv, &c_b5, &work[1], &c__1); 00149 00150 /* C := C - w * v' */ 00151 00152 d__1 = -(*tau); 00153 template_blas_ger(m, n, &d__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], 00154 ldc); 00155 } 00156 } 00157 return 0; 00158 00159 /* End of DLARF */ 00160 00161 } /* dlarf_ */ 00162 00163 #endif