Annotation of rpl/lapack/lapack/dlascl.f, revision 1.16
1.12 bertrand 1: *> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
1.9 bertrand 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
1.15 bertrand 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.
1.9 bertrand 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: *
1.15 bertrand 139: *> \date June 2016
1.9 bertrand 140: *
141: *> \ingroup auxOTHERauxiliary
142: *
143: * =====================================================================
1.1 bertrand 144: SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
145: *
1.15 bertrand 146: * -- LAPACK auxiliary routine (version 3.6.1) --
1.1 bertrand 147: * -- LAPACK is a software package provided by Univ. of Tennessee, --
148: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1.15 bertrand 149: * June 2016
1.1 bertrand 150: *
151: * .. Scalar Arguments ..
152: CHARACTER TYPE
153: INTEGER INFO, KL, KU, LDA, M, N
154: DOUBLE PRECISION CFROM, CTO
155: * ..
156: * .. Array Arguments ..
157: DOUBLE PRECISION A( LDA, * )
158: * ..
159: *
160: * =====================================================================
161: *
162: * .. Parameters ..
163: DOUBLE PRECISION ZERO, ONE
164: PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
165: * ..
166: * .. Local Scalars ..
167: LOGICAL DONE
168: INTEGER I, ITYPE, J, K1, K2, K3, K4
169: DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
170: * ..
171: * .. External Functions ..
172: LOGICAL LSAME, DISNAN
173: DOUBLE PRECISION DLAMCH
174: EXTERNAL LSAME, DLAMCH, DISNAN
175: * ..
176: * .. Intrinsic Functions ..
177: INTRINSIC ABS, MAX, MIN
178: * ..
179: * .. External Subroutines ..
180: EXTERNAL XERBLA
181: * ..
182: * .. Executable Statements ..
183: *
184: * Test the input arguments
185: *
186: INFO = 0
187: *
188: IF( LSAME( TYPE, 'G' ) ) THEN
189: ITYPE = 0
190: ELSE IF( LSAME( TYPE, 'L' ) ) THEN
191: ITYPE = 1
192: ELSE IF( LSAME( TYPE, 'U' ) ) THEN
193: ITYPE = 2
194: ELSE IF( LSAME( TYPE, 'H' ) ) THEN
195: ITYPE = 3
196: ELSE IF( LSAME( TYPE, 'B' ) ) THEN
197: ITYPE = 4
198: ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
199: ITYPE = 5
200: ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
201: ITYPE = 6
202: ELSE
203: ITYPE = -1
204: END IF
205: *
206: IF( ITYPE.EQ.-1 ) THEN
207: INFO = -1
208: ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
209: INFO = -4
210: ELSE IF( DISNAN(CTO) ) THEN
211: INFO = -5
212: ELSE IF( M.LT.0 ) THEN
213: INFO = -6
214: ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
215: $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
216: INFO = -7
217: ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
218: INFO = -9
219: ELSE IF( ITYPE.GE.4 ) THEN
220: IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
221: INFO = -2
222: ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
223: $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
224: $ THEN
225: INFO = -3
226: ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
227: $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
228: $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
229: INFO = -9
230: END IF
231: END IF
232: *
233: IF( INFO.NE.0 ) THEN
234: CALL XERBLA( 'DLASCL', -INFO )
235: RETURN
236: END IF
237: *
238: * Quick return if possible
239: *
240: IF( N.EQ.0 .OR. M.EQ.0 )
241: $ RETURN
242: *
243: * Get machine parameters
244: *
245: SMLNUM = DLAMCH( 'S' )
246: BIGNUM = ONE / SMLNUM
247: *
248: CFROMC = CFROM
249: CTOC = CTO
250: *
251: 10 CONTINUE
252: CFROM1 = CFROMC*SMLNUM
253: IF( CFROM1.EQ.CFROMC ) THEN
254: ! CFROMC is an inf. Multiply by a correctly signed zero for
255: ! finite CTOC, or a NaN if CTOC is infinite.
256: MUL = CTOC / CFROMC
257: DONE = .TRUE.
258: CTO1 = CTOC
259: ELSE
260: CTO1 = CTOC / BIGNUM
261: IF( CTO1.EQ.CTOC ) THEN
262: ! CTOC is either 0 or an inf. In both cases, CTOC itself
263: ! serves as the correct multiplication factor.
264: MUL = CTOC
265: DONE = .TRUE.
266: CFROMC = ONE
267: ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
268: MUL = SMLNUM
269: DONE = .FALSE.
270: CFROMC = CFROM1
271: ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
272: MUL = BIGNUM
273: DONE = .FALSE.
274: CTOC = CTO1
275: ELSE
276: MUL = CTOC / CFROMC
277: DONE = .TRUE.
278: END IF
279: END IF
280: *
281: IF( ITYPE.EQ.0 ) THEN
282: *
283: * Full matrix
284: *
285: DO 30 J = 1, N
286: DO 20 I = 1, M
287: A( I, J ) = A( I, J )*MUL
288: 20 CONTINUE
289: 30 CONTINUE
290: *
291: ELSE IF( ITYPE.EQ.1 ) THEN
292: *
293: * Lower triangular matrix
294: *
295: DO 50 J = 1, N
296: DO 40 I = J, M
297: A( I, J ) = A( I, J )*MUL
298: 40 CONTINUE
299: 50 CONTINUE
300: *
301: ELSE IF( ITYPE.EQ.2 ) THEN
302: *
303: * Upper triangular matrix
304: *
305: DO 70 J = 1, N
306: DO 60 I = 1, MIN( J, M )
307: A( I, J ) = A( I, J )*MUL
308: 60 CONTINUE
309: 70 CONTINUE
310: *
311: ELSE IF( ITYPE.EQ.3 ) THEN
312: *
313: * Upper Hessenberg matrix
314: *
315: DO 90 J = 1, N
316: DO 80 I = 1, MIN( J+1, M )
317: A( I, J ) = A( I, J )*MUL
318: 80 CONTINUE
319: 90 CONTINUE
320: *
321: ELSE IF( ITYPE.EQ.4 ) THEN
322: *
323: * Lower half of a symmetric band matrix
324: *
325: K3 = KL + 1
326: K4 = N + 1
327: DO 110 J = 1, N
328: DO 100 I = 1, MIN( K3, K4-J )
329: A( I, J ) = A( I, J )*MUL
330: 100 CONTINUE
331: 110 CONTINUE
332: *
333: ELSE IF( ITYPE.EQ.5 ) THEN
334: *
335: * Upper half of a symmetric band matrix
336: *
337: K1 = KU + 2
338: K3 = KU + 1
339: DO 130 J = 1, N
340: DO 120 I = MAX( K1-J, 1 ), K3
341: A( I, J ) = A( I, J )*MUL
342: 120 CONTINUE
343: 130 CONTINUE
344: *
345: ELSE IF( ITYPE.EQ.6 ) THEN
346: *
347: * Band matrix
348: *
349: K1 = KL + KU + 2
350: K2 = KL + 1
351: K3 = 2*KL + KU + 1
352: K4 = KL + KU + 1 + M
353: DO 150 J = 1, N
354: DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
355: A( I, J ) = A( I, J )*MUL
356: 140 CONTINUE
357: 150 CONTINUE
358: *
359: END IF
360: *
361: IF( .NOT.DONE )
362: $ GO TO 10
363: *
364: RETURN
365: *
366: * End of DLASCL
367: *
368: 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