Mercurial > hg > octave-nkf

comparison libcruft/lapack/drscl.f @ 2329:30c606bec7a8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[project @ 1996-07-19 01:29:05 by jwe] Initial revision
author jwe
date Fri, 19 Jul 1996 01:29:55 +0000
parents
children 15cddaacbc2d
comparison
equal deleted inserted replaced
2328:b44c3b2a5fce 2329:30c606bec7a8
1 SUBROUTINE DRSCL( N, SA, SX, INCX )
2 *
3 * -- LAPACK auxiliary routine (version 2.0) --
4 * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
5 * Courant Institute, Argonne National Lab, and Rice University
6 * September 30, 1994
7 *
8 * .. Scalar Arguments ..
9 INTEGER INCX, N
10 DOUBLE PRECISION SA
11 * ..
12 * .. Array Arguments ..
13 DOUBLE PRECISION SX( * )
14 * ..
15 *
16 * Purpose
17 * =======
18 *
19 * DRSCL multiplies an n-element real vector x by the real scalar 1/a.
20 * This is done without overflow or underflow as long as
21 * the final result x/a does not overflow or underflow.
22 *
23 * Arguments
24 * =========
25 *
26 * N (input) INTEGER
27 * The number of components of the vector x.
28 *
29 * SA (input) DOUBLE PRECISION
30 * The scalar a which is used to divide each component of x.
31 * SA must be >= 0, or the subroutine will divide by zero.
32 *
33 * SX (input/output) DOUBLE PRECISION array, dimension
34 * (1+(N-1)*abs(INCX))
35 * The n-element vector x.
36 *
37 * INCX (input) INTEGER
38 * The increment between successive values of the vector SX.
39 * > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n
40 *
41 * =====================================================================
42 *
43 * .. Parameters ..
44 DOUBLE PRECISION ONE, ZERO
45 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
46 * ..
47 * .. Local Scalars ..
48 LOGICAL DONE
49 DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
50 * ..
51 * .. External Functions ..
52 DOUBLE PRECISION DLAMCH
53 EXTERNAL DLAMCH
54 * ..
55 * .. External Subroutines ..
56 EXTERNAL DLABAD, DSCAL
57 * ..
58 * .. Intrinsic Functions ..
59 INTRINSIC ABS
60 * ..
61 * .. Executable Statements ..
62 *
63 * Quick return if possible
64 *
65 IF( N.LE.0 )
66 $ RETURN
67 *
68 * Get machine parameters
69 *
70 SMLNUM = DLAMCH( 'S' )
71 BIGNUM = ONE / SMLNUM
72 CALL DLABAD( SMLNUM, BIGNUM )
73 *
74 * Initialize the denominator to SA and the numerator to 1.
75 *
76 CDEN = SA
77 CNUM = ONE
78 *
79 10 CONTINUE
80 CDEN1 = CDEN*SMLNUM
81 CNUM1 = CNUM / BIGNUM
82 IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
83 *
84 * Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
85 *
86 MUL = SMLNUM
87 DONE = .FALSE.
88 CDEN = CDEN1
89 ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
90 *
91 * Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
92 *
93 MUL = BIGNUM
94 DONE = .FALSE.
95 CNUM = CNUM1
96 ELSE
97 *
98 * Multiply X by CNUM / CDEN and return.
99 *
100 MUL = CNUM / CDEN
101 DONE = .TRUE.
102 END IF
103 *
104 * Scale the vector X by MUL
105 *
106 CALL DSCAL( N, MUL, SX, INCX )
107 *
108 IF( .NOT.DONE )
109 $ GO TO 10
110 *
111 RETURN
112 *
113 * End of DRSCL
114 *
115 END