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_RSCL_HEADER 00038 #define TEMPLATE_LAPACK_RSCL_HEADER 00039 00040 00041 template<class Treal> 00042 int template_lapack_rscl(const integer *n, const Treal *sa, Treal *sx, 00043 const integer *incx) 00044 { 00045 /* -- LAPACK auxiliary routine (version 3.0) -- 00046 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 00047 Courant Institute, Argonne National Lab, and Rice University 00048 September 30, 1994 00049 00050 00051 Purpose 00052 ======= 00053 00054 DRSCL multiplies an n-element real vector x by the real scalar 1/a. 00055 This is done without overflow or underflow as long as 00056 the final result x/a does not overflow or underflow. 00057 00058 Arguments 00059 ========= 00060 00061 N (input) INTEGER 00062 The number of components of the vector x. 00063 00064 SA (input) DOUBLE PRECISION 00065 The scalar a which is used to divide each component of x. 00066 SA must be >= 0, or the subroutine will divide by zero. 00067 00068 SX (input/output) DOUBLE PRECISION array, dimension 00069 (1+(N-1)*abs(INCX)) 00070 The n-element vector x. 00071 00072 INCX (input) INTEGER 00073 The increment between successive values of the vector SX. 00074 > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n 00075 00076 ===================================================================== 00077 00078 00079 Quick return if possible 00080 00081 Parameter adjustments */ 00082 Treal cden; 00083 logical done; 00084 Treal cnum, cden1, cnum1; 00085 Treal bignum, smlnum, mul; 00086 00087 --sx; 00088 00089 /* Function Body */ 00090 if (*n <= 0) { 00091 return 0; 00092 } 00093 00094 /* Get machine parameters */ 00095 00096 smlnum = template_lapack_lamch("S", (Treal)0); 00097 bignum = 1. / smlnum; 00098 template_lapack_labad(&smlnum, &bignum); 00099 00100 /* Initialize the denominator to SA and the numerator to 1. */ 00101 00102 cden = *sa; 00103 cnum = 1.; 00104 00105 L10: 00106 cden1 = cden * smlnum; 00107 cnum1 = cnum / bignum; 00108 if (absMACRO(cden1) > absMACRO(cnum) && cnum != 0.) { 00109 00110 /* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */ 00111 00112 mul = smlnum; 00113 done = FALSE_; 00114 cden = cden1; 00115 } else if (absMACRO(cnum1) > absMACRO(cden)) { 00116 00117 /* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */ 00118 00119 mul = bignum; 00120 done = FALSE_; 00121 cnum = cnum1; 00122 } else { 00123 00124 /* Multiply X by CNUM / CDEN and return. */ 00125 00126 mul = cnum / cden; 00127 done = TRUE_; 00128 } 00129 00130 /* Scale the vector X by MUL */ 00131 00132 dscal_(n, &mul, &sx[1], incx); 00133 00134 if (! done) { 00135 goto L10; 00136 } 00137 00138 return 0; 00139 00140 /* End of DRSCL */ 00141 00142 } /* drscl_ */ 00143 00144 #endif