1 /* ./src_f77/drscl.f -- translated by f2c (version 20030320).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include <punc/vf2c.h>
7
drscl_(integer * n,doublereal * sa,doublereal * sx,integer * incx)8 /* Subroutine */ int drscl_(integer *n, doublereal *sa, doublereal *sx,
9 integer *incx)
10 {
11 static doublereal mul, cden;
12 static logical done;
13 static doublereal cnum, cden1, cnum1;
14 extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
15 integer *), dlabad_(doublereal *, doublereal *);
16 extern doublereal dlamch_(char *, ftnlen);
17 static doublereal bignum, smlnum;
18
19
20 /* -- LAPACK auxiliary routine (version 3.0) -- */
21 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
22 /* Courant Institute, Argonne National Lab, and Rice University */
23 /* September 30, 1994 */
24
25 /* .. Scalar Arguments .. */
26 /* .. */
27 /* .. Array Arguments .. */
28 /* .. */
29
30 /* Purpose */
31 /* ======= */
32
33 /* DRSCL multiplies an n-element real vector x by the real scalar 1/a. */
34 /* This is done without overflow or underflow as long as */
35 /* the final result x/a does not overflow or underflow. */
36
37 /* Arguments */
38 /* ========= */
39
40 /* N (input) INTEGER */
41 /* The number of components of the vector x. */
42
43 /* SA (input) DOUBLE PRECISION */
44 /* The scalar a which is used to divide each component of x. */
45 /* SA must be >= 0, or the subroutine will divide by zero. */
46
47 /* SX (input/output) DOUBLE PRECISION array, dimension */
48 /* (1+(N-1)*abs(INCX)) */
49 /* The n-element vector x. */
50
51 /* INCX (input) INTEGER */
52 /* The increment between successive values of the vector SX. */
53 /* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n */
54
55 /* ===================================================================== */
56
57 /* .. Parameters .. */
58 /* .. */
59 /* .. Local Scalars .. */
60 /* .. */
61 /* .. External Functions .. */
62 /* .. */
63 /* .. External Subroutines .. */
64 /* .. */
65 /* .. Intrinsic Functions .. */
66 /* .. */
67 /* .. Executable Statements .. */
68
69 /* Quick return if possible */
70
71 /* Parameter adjustments */
72 --sx;
73
74 /* Function Body */
75 if (*n <= 0) {
76 return 0;
77 }
78
79 /* Get machine parameters */
80
81 smlnum = dlamch_("S", (ftnlen)1);
82 bignum = 1. / smlnum;
83 dlabad_(&smlnum, &bignum);
84
85 /* Initialize the denominator to SA and the numerator to 1. */
86
87 cden = *sa;
88 cnum = 1.;
89
90 L10:
91 cden1 = cden * smlnum;
92 cnum1 = cnum / bignum;
93 if (abs(cden1) > abs(cnum) && cnum != 0.) {
94
95 /* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */
96
97 mul = smlnum;
98 done = FALSE_;
99 cden = cden1;
100 } else if (abs(cnum1) > abs(cden)) {
101
102 /* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */
103
104 mul = bignum;
105 done = FALSE_;
106 cnum = cnum1;
107 } else {
108
109 /* Multiply X by CNUM / CDEN and return. */
110
111 mul = cnum / cden;
112 done = TRUE_;
113 }
114
115 /* Scale the vector X by MUL */
116
117 dscal_(n, &mul, &sx[1], incx);
118
119 if (! done) {
120 goto L10;
121 }
122
123 return 0;
124
125 /* End of DRSCL */
126
127 } /* drscl_ */
128
129