1: *> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
2: *
3: * =========== DOCUMENTATION ===========
4: *
5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
7: *
8: *> \htmlonly
9: *> Download DLASCL + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlascl.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlascl.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlascl.f">
15: *> [TXT]</a>
16: *> \endhtmlonly
17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
22: *
23: * .. Scalar Arguments ..
24: * CHARACTER TYPE
25: * INTEGER INFO, KL, KU, LDA, M, N
26: * DOUBLE PRECISION CFROM, CTO
27: * ..
28: * .. Array Arguments ..
29: * DOUBLE PRECISION A( LDA, * )
30: * ..
31: *
32: *
33: *> \par Purpose:
34: * =============
35: *>
36: *> \verbatim
37: *>
38: *> DLASCL multiplies the M by N real matrix A by the real scalar
39: *> CTO/CFROM. This is done without over/underflow as long as the final
40: *> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
41: *> A may be full, upper triangular, lower triangular, upper Hessenberg,
42: *> or banded.
43: *> \endverbatim
44: *
45: * Arguments:
46: * ==========
47: *
48: *> \param[in] TYPE
49: *> \verbatim
50: *> TYPE is CHARACTER*1
51: *> TYPE indices the storage type of the input matrix.
52: *> = 'G': A is a full matrix.
53: *> = 'L': A is a lower triangular matrix.
54: *> = 'U': A is an upper triangular matrix.
55: *> = 'H': A is an upper Hessenberg matrix.
56: *> = 'B': A is a symmetric band matrix with lower bandwidth KL
57: *> and upper bandwidth KU and with the only the lower
58: *> half stored.
59: *> = 'Q': A is a symmetric band matrix with lower bandwidth KL
60: *> and upper bandwidth KU and with the only the upper
61: *> half stored.
62: *> = 'Z': A is a band matrix with lower bandwidth KL and upper
63: *> bandwidth KU. See DGBTRF for storage details.
64: *> \endverbatim
65: *>
66: *> \param[in] KL
67: *> \verbatim
68: *> KL is INTEGER
69: *> The lower bandwidth of A. Referenced only if TYPE = 'B',
70: *> 'Q' or 'Z'.
71: *> \endverbatim
72: *>
73: *> \param[in] KU
74: *> \verbatim
75: *> KU is INTEGER
76: *> The upper bandwidth of A. Referenced only if TYPE = 'B',
77: *> 'Q' or 'Z'.
78: *> \endverbatim
79: *>
80: *> \param[in] CFROM
81: *> \verbatim
82: *> CFROM is DOUBLE PRECISION
83: *> \endverbatim
84: *>
85: *> \param[in] CTO
86: *> \verbatim
87: *> CTO is DOUBLE PRECISION
88: *>
89: *> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
90: *> without over/underflow if the final result CTO*A(I,J)/CFROM
91: *> can be represented without over/underflow. CFROM must be
92: *> nonzero.
93: *> \endverbatim
94: *>
95: *> \param[in] M
96: *> \verbatim
97: *> M is INTEGER
98: *> The number of rows of the matrix A. M >= 0.
99: *> \endverbatim
100: *>
101: *> \param[in] N
102: *> \verbatim
103: *> N is INTEGER
104: *> The number of columns of the matrix A. N >= 0.
105: *> \endverbatim
106: *>
107: *> \param[in,out] A
108: *> \verbatim
109: *> A is DOUBLE PRECISION array, dimension (LDA,N)
110: *> The matrix to be multiplied by CTO/CFROM. See TYPE for the
111: *> storage type.
112: *> \endverbatim
113: *>
114: *> \param[in] LDA
115: *> \verbatim
116: *> LDA is INTEGER
117: *> The leading dimension of the array A.
118: *> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M);
119: *> TYPE = 'B', LDA >= KL+1;
120: *> TYPE = 'Q', LDA >= KU+1;
121: *> TYPE = 'Z', LDA >= 2*KL+KU+1.
122: *> \endverbatim
123: *>
124: *> \param[out] INFO
125: *> \verbatim
126: *> INFO is INTEGER
127: *> 0 - successful exit
128: *> <0 - if INFO = -i, the i-th argument had an illegal value.
129: *> \endverbatim
130: *
131: * Authors:
132: * ========
133: *
134: *> \author Univ. of Tennessee
135: *> \author Univ. of California Berkeley
136: *> \author Univ. of Colorado Denver
137: *> \author NAG Ltd.
138: *
139: *> \ingroup OTHERauxiliary
140: *
141: * =====================================================================
142: SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
143: *
144: * -- LAPACK auxiliary routine --
145: * -- LAPACK is a software package provided by Univ. of Tennessee, --
146: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
147: *
148: * .. Scalar Arguments ..
149: CHARACTER TYPE
150: INTEGER INFO, KL, KU, LDA, M, N
151: DOUBLE PRECISION CFROM, CTO
152: * ..
153: * .. Array Arguments ..
154: DOUBLE PRECISION A( LDA, * )
155: * ..
156: *
157: * =====================================================================
158: *
159: * .. Parameters ..
160: DOUBLE PRECISION ZERO, ONE
161: PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
162: * ..
163: * .. Local Scalars ..
164: LOGICAL DONE
165: INTEGER I, ITYPE, J, K1, K2, K3, K4
166: DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
167: * ..
168: * .. External Functions ..
169: LOGICAL LSAME, DISNAN
170: DOUBLE PRECISION DLAMCH
171: EXTERNAL LSAME, DLAMCH, DISNAN
172: * ..
173: * .. Intrinsic Functions ..
174: INTRINSIC ABS, MAX, MIN
175: * ..
176: * .. External Subroutines ..
177: EXTERNAL XERBLA
178: * ..
179: * .. Executable Statements ..
180: *
181: * Test the input arguments
182: *
183: INFO = 0
184: *
185: IF( LSAME( TYPE, 'G' ) ) THEN
186: ITYPE = 0
187: ELSE IF( LSAME( TYPE, 'L' ) ) THEN
188: ITYPE = 1
189: ELSE IF( LSAME( TYPE, 'U' ) ) THEN
190: ITYPE = 2
191: ELSE IF( LSAME( TYPE, 'H' ) ) THEN
192: ITYPE = 3
193: ELSE IF( LSAME( TYPE, 'B' ) ) THEN
194: ITYPE = 4
195: ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
196: ITYPE = 5
197: ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
198: ITYPE = 6
199: ELSE
200: ITYPE = -1
201: END IF
202: *
203: IF( ITYPE.EQ.-1 ) THEN
204: INFO = -1
205: ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
206: INFO = -4
207: ELSE IF( DISNAN(CTO) ) THEN
208: INFO = -5
209: ELSE IF( M.LT.0 ) THEN
210: INFO = -6
211: ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
212: $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
213: INFO = -7
214: ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
215: INFO = -9
216: ELSE IF( ITYPE.GE.4 ) THEN
217: IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
218: INFO = -2
219: ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
220: $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
221: $ THEN
222: INFO = -3
223: ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
224: $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
225: $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
226: INFO = -9
227: END IF
228: END IF
229: *
230: IF( INFO.NE.0 ) THEN
231: CALL XERBLA( 'DLASCL', -INFO )
232: RETURN
233: END IF
234: *
235: * Quick return if possible
236: *
237: IF( N.EQ.0 .OR. M.EQ.0 )
238: $ RETURN
239: *
240: * Get machine parameters
241: *
242: SMLNUM = DLAMCH( 'S' )
243: BIGNUM = ONE / SMLNUM
244: *
245: CFROMC = CFROM
246: CTOC = CTO
247: *
248: 10 CONTINUE
249: CFROM1 = CFROMC*SMLNUM
250: IF( CFROM1.EQ.CFROMC ) THEN
251: ! CFROMC is an inf. Multiply by a correctly signed zero for
252: ! finite CTOC, or a NaN if CTOC is infinite.
253: MUL = CTOC / CFROMC
254: DONE = .TRUE.
255: CTO1 = CTOC
256: ELSE
257: CTO1 = CTOC / BIGNUM
258: IF( CTO1.EQ.CTOC ) THEN
259: ! CTOC is either 0 or an inf. In both cases, CTOC itself
260: ! serves as the correct multiplication factor.
261: MUL = CTOC
262: DONE = .TRUE.
263: CFROMC = ONE
264: ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
265: MUL = SMLNUM
266: DONE = .FALSE.
267: CFROMC = CFROM1
268: ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
269: MUL = BIGNUM
270: DONE = .FALSE.
271: CTOC = CTO1
272: ELSE
273: MUL = CTOC / CFROMC
274: DONE = .TRUE.
275: IF (MUL .EQ. ONE)
276: $ RETURN
277: END IF
278: END IF
279: *
280: IF( ITYPE.EQ.0 ) THEN
281: *
282: * Full matrix
283: *
284: DO 30 J = 1, N
285: DO 20 I = 1, M
286: A( I, J ) = A( I, J )*MUL
287: 20 CONTINUE
288: 30 CONTINUE
289: *
290: ELSE IF( ITYPE.EQ.1 ) THEN
291: *
292: * Lower triangular matrix
293: *
294: DO 50 J = 1, N
295: DO 40 I = J, M
296: A( I, J ) = A( I, J )*MUL
297: 40 CONTINUE
298: 50 CONTINUE
299: *
300: ELSE IF( ITYPE.EQ.2 ) THEN
301: *
302: * Upper triangular matrix
303: *
304: DO 70 J = 1, N
305: DO 60 I = 1, MIN( J, M )
306: A( I, J ) = A( I, J )*MUL
307: 60 CONTINUE
308: 70 CONTINUE
309: *
310: ELSE IF( ITYPE.EQ.3 ) THEN
311: *
312: * Upper Hessenberg matrix
313: *
314: DO 90 J = 1, N
315: DO 80 I = 1, MIN( J+1, M )
316: A( I, J ) = A( I, J )*MUL
317: 80 CONTINUE
318: 90 CONTINUE
319: *
320: ELSE IF( ITYPE.EQ.4 ) THEN
321: *
322: * Lower half of a symmetric band matrix
323: *
324: K3 = KL + 1
325: K4 = N + 1
326: DO 110 J = 1, N
327: DO 100 I = 1, MIN( K3, K4-J )
328: A( I, J ) = A( I, J )*MUL
329: 100 CONTINUE
330: 110 CONTINUE
331: *
332: ELSE IF( ITYPE.EQ.5 ) THEN
333: *
334: * Upper half of a symmetric band matrix
335: *
336: K1 = KU + 2
337: K3 = KU + 1
338: DO 130 J = 1, N
339: DO 120 I = MAX( K1-J, 1 ), K3
340: A( I, J ) = A( I, J )*MUL
341: 120 CONTINUE
342: 130 CONTINUE
343: *
344: ELSE IF( ITYPE.EQ.6 ) THEN
345: *
346: * Band matrix
347: *
348: K1 = KL + KU + 2
349: K2 = KL + 1
350: K3 = 2*KL + KU + 1
351: K4 = KL + KU + 1 + M
352: DO 150 J = 1, N
353: DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
354: A( I, J ) = A( I, J )*MUL
355: 140 CONTINUE
356: 150 CONTINUE
357: *
358: END IF
359: *
360: IF( .NOT.DONE )
361: $ GO TO 10
362: *
363: RETURN
364: *
365: * End of DLASCL
366: *
367: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dlascl.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack