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_GETRS_HEADER 00038 #define TEMPLATE_LAPACK_GETRS_HEADER 00039 00040 00041 template<class Treal> 00042 int template_lapack_getrs(const char *trans, const integer *n, const integer *nrhs, 00043 const Treal *a, const integer *lda, const integer *ipiv, Treal *b, const integer * 00044 ldb, integer *info) 00045 { 00046 /* -- LAPACK routine (version 3.0) -- 00047 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 00048 Courant Institute, Argonne National Lab, and Rice University 00049 March 31, 1993 00050 00051 00052 Purpose 00053 ======= 00054 00055 DGETRS solves a system of linear equations 00056 A * X = B or A' * X = B 00057 with a general N-by-N matrix A using the LU factorization computed 00058 by DGETRF. 00059 00060 Arguments 00061 ========= 00062 00063 TRANS (input) CHARACTER*1 00064 Specifies the form of the system of equations: 00065 = 'N': A * X = B (No transpose) 00066 = 'T': A'* X = B (Transpose) 00067 = 'C': A'* X = B (Conjugate transpose = Transpose) 00068 00069 N (input) INTEGER 00070 The order of the matrix A. N >= 0. 00071 00072 NRHS (input) INTEGER 00073 The number of right hand sides, i.e., the number of columns 00074 of the matrix B. NRHS >= 0. 00075 00076 A (input) DOUBLE PRECISION array, dimension (LDA,N) 00077 The factors L and U from the factorization A = P*L*U 00078 as computed by DGETRF. 00079 00080 LDA (input) INTEGER 00081 The leading dimension of the array A. LDA >= max(1,N). 00082 00083 IPIV (input) INTEGER array, dimension (N) 00084 The pivot indices from DGETRF; for 1<=i<=N, row i of the 00085 matrix was interchanged with row IPIV(i). 00086 00087 B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) 00088 On entry, the right hand side matrix B. 00089 On exit, the solution matrix X. 00090 00091 LDB (input) INTEGER 00092 The leading dimension of the array B. LDB >= max(1,N). 00093 00094 INFO (output) INTEGER 00095 = 0: successful exit 00096 < 0: if INFO = -i, the i-th argument had an illegal value 00097 00098 ===================================================================== 00099 00100 00101 Test the input parameters. 00102 00103 Parameter adjustments */ 00104 /* Table of constant values */ 00105 integer c__1 = 1; 00106 Treal c_b12 = 1.; 00107 integer c_n1 = -1; 00108 00109 /* System generated locals */ 00110 integer a_dim1, a_offset, b_dim1, b_offset, i__1; 00111 /* Local variables */ 00112 logical notran; 00113 00114 00115 a_dim1 = *lda; 00116 a_offset = 1 + a_dim1 * 1; 00117 a -= a_offset; 00118 --ipiv; 00119 b_dim1 = *ldb; 00120 b_offset = 1 + b_dim1 * 1; 00121 b -= b_offset; 00122 00123 /* Function Body */ 00124 *info = 0; 00125 notran = template_blas_lsame(trans, "N"); 00126 if (! notran && ! template_blas_lsame(trans, "T") && ! template_blas_lsame( 00127 trans, "C")) { 00128 *info = -1; 00129 } else if (*n < 0) { 00130 *info = -2; 00131 } else if (*nrhs < 0) { 00132 *info = -3; 00133 } else if (*lda < maxMACRO(1,*n)) { 00134 *info = -5; 00135 } else if (*ldb < maxMACRO(1,*n)) { 00136 *info = -8; 00137 } 00138 if (*info != 0) { 00139 i__1 = -(*info); 00140 template_blas_erbla("GETRS ", &i__1); 00141 return 0; 00142 } 00143 00144 /* Quick return if possible */ 00145 00146 if (*n == 0 || *nrhs == 0) { 00147 return 0; 00148 } 00149 00150 if (notran) { 00151 00152 /* Solve A * X = B. 00153 00154 Apply row interchanges to the right hand sides. */ 00155 00156 template_lapack_laswp(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1); 00157 00158 /* Solve L*X = B, overwriting B with X. */ 00159 00160 template_blas_trsm("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b12, &a[ 00161 a_offset], lda, &b[b_offset], ldb); 00162 00163 /* Solve U*X = B, overwriting B with X. */ 00164 00165 template_blas_trsm("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b12, & 00166 a[a_offset], lda, &b[b_offset], ldb); 00167 } else { 00168 00169 /* Solve A' * X = B. 00170 00171 Solve U'*X = B, overwriting B with X. */ 00172 00173 template_blas_trsm("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b12, &a[ 00174 a_offset], lda, &b[b_offset], ldb); 00175 00176 /* Solve L'*X = B, overwriting B with X. */ 00177 00178 template_blas_trsm("Left", "Lower", "Transpose", "Unit", n, nrhs, &c_b12, &a[ 00179 a_offset], lda, &b[b_offset], ldb); 00180 00181 /* Apply row interchanges to the solution vectors. */ 00182 00183 template_lapack_laswp(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1); 00184 } 00185 00186 return 0; 00187 00188 /* End of DGETRS */ 00189 00190 } /* dgetrs_ */ 00191 00192 #endif