ergo
template_lapack_rscl.h
Go to the documentation of this file.
1/* Ergo, version 3.8, a program for linear scaling electronic structure
2 * calculations.
3 * Copyright (C) 2019 Elias Rudberg, Emanuel H. Rubensson, Pawel Salek,
4 * and Anastasia Kruchinina.
5 *
6 * This program is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, either version 3 of the License, or
9 * (at your option) any later version.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
15 *
16 * You should have received a copy of the GNU General Public License
17 * along with this program. If not, see <http://www.gnu.org/licenses/>.
18 *
19 * Primary academic reference:
20 * Ergo: An open-source program for linear-scaling electronic structure
21 * calculations,
22 * Elias Rudberg, Emanuel H. Rubensson, Pawel Salek, and Anastasia
23 * Kruchinina,
24 * SoftwareX 7, 107 (2018),
25 * <http://dx.doi.org/10.1016/j.softx.2018.03.005>
26 *
27 * For further information about Ergo, see <http://www.ergoscf.org>.
28 */
29
30 /* This file belongs to the template_lapack part of the Ergo source
31 * code. The source files in the template_lapack directory are modified
32 * versions of files originally distributed as CLAPACK, see the
33 * Copyright/license notice in the file template_lapack/COPYING.
34 */
35
36
37#ifndef TEMPLATE_LAPACK_RSCL_HEADER
38#define TEMPLATE_LAPACK_RSCL_HEADER
39
40
41template<class Treal>
42int template_lapack_rscl(const integer *n, const Treal *sa, Treal *sx,
43 const integer *incx)
44{
45/* -- LAPACK auxiliary routine (version 3.0) --
46 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
47 Courant Institute, Argonne National Lab, and Rice University
48 September 30, 1994
49
50
51 Purpose
52 =======
53
54 DRSCL multiplies an n-element real vector x by the real scalar 1/a.
55 This is done without overflow or underflow as long as
56 the final result x/a does not overflow or underflow.
57
58 Arguments
59 =========
60
61 N (input) INTEGER
62 The number of components of the vector x.
63
64 SA (input) DOUBLE PRECISION
65 The scalar a which is used to divide each component of x.
66 SA must be >= 0, or the subroutine will divide by zero.
67
68 SX (input/output) DOUBLE PRECISION array, dimension
69 (1+(N-1)*abs(INCX))
70 The n-element vector x.
71
72 INCX (input) INTEGER
73 The increment between successive values of the vector SX.
74 > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n
75
76 =====================================================================
77
78
79 Quick return if possible
80
81 Parameter adjustments */
82 Treal cden;
83 logical done;
84 Treal cnum, cden1, cnum1;
85 Treal bignum, smlnum, mul;
86
87 --sx;
88
89 /* Function Body */
90 if (*n <= 0) {
91 return 0;
92 }
93
94/* Get machine parameters */
95
96 smlnum = template_lapack_lamch("S", (Treal)0);
97 bignum = 1. / smlnum;
98 template_lapack_labad(&smlnum, &bignum);
99
100/* Initialize the denominator to SA and the numerator to 1. */
101
102 cden = *sa;
103 cnum = 1.;
104
105L10:
106 cden1 = cden * smlnum;
107 cnum1 = cnum / bignum;
108 if (absMACRO(cden1) > absMACRO(cnum) && cnum != 0.) {
109
110/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */
111
112 mul = smlnum;
113 done = FALSE_;
114 cden = cden1;
115 } else if (absMACRO(cnum1) > absMACRO(cden)) {
116
117/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */
118
119 mul = bignum;
120 done = FALSE_;
121 cnum = cnum1;
122 } else {
123
124/* Multiply X by CNUM / CDEN and return. */
125
126 mul = cnum / cden;
127 done = TRUE_;
128 }
129
130/* Scale the vector X by MUL */
131
132 dscal_(n, &mul, &sx[1], incx);
133
134 if (! done) {
135 goto L10;
136 }
137
138 return 0;
139
140/* End of DRSCL */
141
142} /* drscl_ */
143
144#endif
void dscal_(const int *n, const double *da, double *dx, const int *incx)
int integer
Definition: template_blas_common.h:40
#define absMACRO(x)
Definition: template_blas_common.h:47
bool logical
Definition: template_blas_common.h:41
#define TRUE_
Definition: template_lapack_common.h:42
#define FALSE_
Definition: template_lapack_common.h:43
int template_lapack_labad(Treal *small, Treal *large)
Definition: template_lapack_labad.h:42
Treal template_lapack_lamch(const char *cmach, Treal dummyReal)
Definition: template_lapack_lamch.h:202
int template_lapack_rscl(const integer *n, const Treal *sa, Treal *sx, const integer *incx)
Definition: template_lapack_rscl.h:42