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