ergo
|
00001 /* Ergo, version 3.2, a program for linear scaling electronic structure 00002 * calculations. 00003 * Copyright (C) 2012 Elias Rudberg, Emanuel H. Rubensson, and Pawel Salek. 00004 * 00005 * This program is free software: you can redistribute it and/or modify 00006 * it under the terms of the GNU General Public License as published by 00007 * the Free Software Foundation, either version 3 of the License, or 00008 * (at your option) any later version. 00009 * 00010 * This program is distributed in the hope that it will be useful, 00011 * but WITHOUT ANY WARRANTY; without even the implied warranty of 00012 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00013 * GNU General Public License for more details. 00014 * 00015 * You should have received a copy of the GNU General Public License 00016 * along with this program. If not, see <http://www.gnu.org/licenses/>. 00017 * 00018 * Primary academic reference: 00019 * KohnâSham Density Functional Theory Electronic Structure Calculations 00020 * with Linearly Scaling Computational Time and Memory Usage, 00021 * Elias Rudberg, Emanuel H. Rubensson, and Pawel Salek, 00022 * J. Chem. Theory Comput. 7, 340 (2011), 00023 * <http://dx.doi.org/10.1021/ct100611z> 00024 * 00025 * For further information about Ergo, see <http://www.ergoscf.org>. 00026 */ 00027 00028 /* This file belongs to the template_lapack part of the Ergo source 00029 * code. The source files in the template_lapack directory are modified 00030 * versions of files originally distributed as CLAPACK, see the 00031 * Copyright/license notice in the file template_lapack/COPYING. 00032 */ 00033 00034 00035 #ifndef TEMPLATE_LAPACK_RSCL_HEADER 00036 #define TEMPLATE_LAPACK_RSCL_HEADER 00037 00038 00039 template<class Treal> 00040 int template_lapack_rscl(const integer *n, const Treal *sa, Treal *sx, 00041 const integer *incx) 00042 { 00043 /* -- LAPACK auxiliary routine (version 3.0) -- 00044 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 00045 Courant Institute, Argonne National Lab, and Rice University 00046 September 30, 1994 00047 00048 00049 Purpose 00050 ======= 00051 00052 DRSCL multiplies an n-element real vector x by the real scalar 1/a. 00053 This is done without overflow or underflow as long as 00054 the final result x/a does not overflow or underflow. 00055 00056 Arguments 00057 ========= 00058 00059 N (input) INTEGER 00060 The number of components of the vector x. 00061 00062 SA (input) DOUBLE PRECISION 00063 The scalar a which is used to divide each component of x. 00064 SA must be >= 0, or the subroutine will divide by zero. 00065 00066 SX (input/output) DOUBLE PRECISION array, dimension 00067 (1+(N-1)*abs(INCX)) 00068 The n-element vector x. 00069 00070 INCX (input) INTEGER 00071 The increment between successive values of the vector SX. 00072 > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n 00073 00074 ===================================================================== 00075 00076 00077 Quick return if possible 00078 00079 Parameter adjustments */ 00080 Treal cden; 00081 logical done; 00082 Treal cnum, cden1, cnum1; 00083 Treal bignum, smlnum, mul; 00084 00085 --sx; 00086 00087 /* Function Body */ 00088 if (*n <= 0) { 00089 return 0; 00090 } 00091 00092 /* Get machine parameters */ 00093 00094 smlnum = template_lapack_lamch("S", (Treal)0); 00095 bignum = 1. / smlnum; 00096 template_lapack_labad(&smlnum, &bignum); 00097 00098 /* Initialize the denominator to SA and the numerator to 1. */ 00099 00100 cden = *sa; 00101 cnum = 1.; 00102 00103 L10: 00104 cden1 = cden * smlnum; 00105 cnum1 = cnum / bignum; 00106 if (absMACRO(cden1) > absMACRO(cnum) && cnum != 0.) { 00107 00108 /* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */ 00109 00110 mul = smlnum; 00111 done = FALSE_; 00112 cden = cden1; 00113 } else if (absMACRO(cnum1) > absMACRO(cden)) { 00114 00115 /* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */ 00116 00117 mul = bignum; 00118 done = FALSE_; 00119 cnum = cnum1; 00120 } else { 00121 00122 /* Multiply X by CNUM / CDEN and return. */ 00123 00124 mul = cnum / cden; 00125 done = TRUE_; 00126 } 00127 00128 /* Scale the vector X by MUL */ 00129 00130 dscal_(n, &mul, &sx[1], incx); 00131 00132 if (! done) { 00133 goto L10; 00134 } 00135 00136 return 0; 00137 00138 /* End of DRSCL */ 00139 00140 } /* drscl_ */ 00141 00142 #endif