1: SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
2: *
3: * -- LAPACK auxiliary routine (version 3.2) --
4: * -- LAPACK is a software package provided by Univ. of Tennessee, --
5: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
6: * November 2006
7: *
8: * .. Scalar Arguments ..
9: CHARACTER TYPE
10: INTEGER INFO, KL, KU, LDA, M, N
11: DOUBLE PRECISION CFROM, CTO
12: * ..
13: * .. Array Arguments ..
14: COMPLEX*16 A( LDA, * )
15: * ..
16: *
17: * Purpose
18: * =======
19: *
20: * ZLASCL multiplies the M by N complex matrix A by the real scalar
21: * CTO/CFROM. This is done without over/underflow as long as the final
22: * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
23: * A may be full, upper triangular, lower triangular, upper Hessenberg,
24: * or banded.
25: *
26: * Arguments
27: * =========
28: *
29: * TYPE (input) CHARACTER*1
30: * TYPE indices the storage type of the input matrix.
31: * = 'G': A is a full matrix.
32: * = 'L': A is a lower triangular matrix.
33: * = 'U': A is an upper triangular matrix.
34: * = 'H': A is an upper Hessenberg matrix.
35: * = 'B': A is a symmetric band matrix with lower bandwidth KL
36: * and upper bandwidth KU and with the only the lower
37: * half stored.
38: * = 'Q': A is a symmetric band matrix with lower bandwidth KL
39: * and upper bandwidth KU and with the only the upper
40: * half stored.
41: * = 'Z': A is a band matrix with lower bandwidth KL and upper
42: * bandwidth KU.
43: *
44: * KL (input) INTEGER
45: * The lower bandwidth of A. Referenced only if TYPE = 'B',
46: * 'Q' or 'Z'.
47: *
48: * KU (input) INTEGER
49: * The upper bandwidth of A. Referenced only if TYPE = 'B',
50: * 'Q' or 'Z'.
51: *
52: * CFROM (input) DOUBLE PRECISION
53: * CTO (input) DOUBLE PRECISION
54: * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
55: * without over/underflow if the final result CTO*A(I,J)/CFROM
56: * can be represented without over/underflow. CFROM must be
57: * nonzero.
58: *
59: * M (input) INTEGER
60: * The number of rows of the matrix A. M >= 0.
61: *
62: * N (input) INTEGER
63: * The number of columns of the matrix A. N >= 0.
64: *
65: * A (input/output) COMPLEX*16 array, dimension (LDA,N)
66: * The matrix to be multiplied by CTO/CFROM. See TYPE for the
67: * storage type.
68: *
69: * LDA (input) INTEGER
70: * The leading dimension of the array A. LDA >= max(1,M).
71: *
72: * INFO (output) INTEGER
73: * 0 - successful exit
74: * <0 - if INFO = -i, the i-th argument had an illegal value.
75: *
76: * =====================================================================
77: *
78: * .. Parameters ..
79: DOUBLE PRECISION ZERO, ONE
80: PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
81: * ..
82: * .. Local Scalars ..
83: LOGICAL DONE
84: INTEGER I, ITYPE, J, K1, K2, K3, K4
85: DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
86: * ..
87: * .. External Functions ..
88: LOGICAL LSAME, DISNAN
89: DOUBLE PRECISION DLAMCH
90: EXTERNAL LSAME, DLAMCH, DISNAN
91: * ..
92: * .. Intrinsic Functions ..
93: INTRINSIC ABS, MAX, MIN
94: * ..
95: * .. External Subroutines ..
96: EXTERNAL XERBLA
97: * ..
98: * .. Executable Statements ..
99: *
100: * Test the input arguments
101: *
102: INFO = 0
103: *
104: IF( LSAME( TYPE, 'G' ) ) THEN
105: ITYPE = 0
106: ELSE IF( LSAME( TYPE, 'L' ) ) THEN
107: ITYPE = 1
108: ELSE IF( LSAME( TYPE, 'U' ) ) THEN
109: ITYPE = 2
110: ELSE IF( LSAME( TYPE, 'H' ) ) THEN
111: ITYPE = 3
112: ELSE IF( LSAME( TYPE, 'B' ) ) THEN
113: ITYPE = 4
114: ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
115: ITYPE = 5
116: ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
117: ITYPE = 6
118: ELSE
119: ITYPE = -1
120: END IF
121: *
122: IF( ITYPE.EQ.-1 ) THEN
123: INFO = -1
124: ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
125: INFO = -4
126: ELSE IF( DISNAN(CTO) ) THEN
127: INFO = -5
128: ELSE IF( M.LT.0 ) THEN
129: INFO = -6
130: ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
131: $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
132: INFO = -7
133: ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
134: INFO = -9
135: ELSE IF( ITYPE.GE.4 ) THEN
136: IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
137: INFO = -2
138: ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
139: $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
140: $ THEN
141: INFO = -3
142: ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
143: $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
144: $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
145: INFO = -9
146: END IF
147: END IF
148: *
149: IF( INFO.NE.0 ) THEN
150: CALL XERBLA( 'ZLASCL', -INFO )
151: RETURN
152: END IF
153: *
154: * Quick return if possible
155: *
156: IF( N.EQ.0 .OR. M.EQ.0 )
157: $ RETURN
158: *
159: * Get machine parameters
160: *
161: SMLNUM = DLAMCH( 'S' )
162: BIGNUM = ONE / SMLNUM
163: *
164: CFROMC = CFROM
165: CTOC = CTO
166: *
167: 10 CONTINUE
168: CFROM1 = CFROMC*SMLNUM
169: IF( CFROM1.EQ.CFROMC ) THEN
170: ! CFROMC is an inf. Multiply by a correctly signed zero for
171: ! finite CTOC, or a NaN if CTOC is infinite.
172: MUL = CTOC / CFROMC
173: DONE = .TRUE.
174: CTO1 = CTOC
175: ELSE
176: CTO1 = CTOC / BIGNUM
177: IF( CTO1.EQ.CTOC ) THEN
178: ! CTOC is either 0 or an inf. In both cases, CTOC itself
179: ! serves as the correct multiplication factor.
180: MUL = CTOC
181: DONE = .TRUE.
182: CFROMC = ONE
183: ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
184: MUL = SMLNUM
185: DONE = .FALSE.
186: CFROMC = CFROM1
187: ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
188: MUL = BIGNUM
189: DONE = .FALSE.
190: CTOC = CTO1
191: ELSE
192: MUL = CTOC / CFROMC
193: DONE = .TRUE.
194: END IF
195: END IF
196: *
197: IF( ITYPE.EQ.0 ) THEN
198: *
199: * Full matrix
200: *
201: DO 30 J = 1, N
202: DO 20 I = 1, M
203: A( I, J ) = A( I, J )*MUL
204: 20 CONTINUE
205: 30 CONTINUE
206: *
207: ELSE IF( ITYPE.EQ.1 ) THEN
208: *
209: * Lower triangular matrix
210: *
211: DO 50 J = 1, N
212: DO 40 I = J, M
213: A( I, J ) = A( I, J )*MUL
214: 40 CONTINUE
215: 50 CONTINUE
216: *
217: ELSE IF( ITYPE.EQ.2 ) THEN
218: *
219: * Upper triangular matrix
220: *
221: DO 70 J = 1, N
222: DO 60 I = 1, MIN( J, M )
223: A( I, J ) = A( I, J )*MUL
224: 60 CONTINUE
225: 70 CONTINUE
226: *
227: ELSE IF( ITYPE.EQ.3 ) THEN
228: *
229: * Upper Hessenberg matrix
230: *
231: DO 90 J = 1, N
232: DO 80 I = 1, MIN( J+1, M )
233: A( I, J ) = A( I, J )*MUL
234: 80 CONTINUE
235: 90 CONTINUE
236: *
237: ELSE IF( ITYPE.EQ.4 ) THEN
238: *
239: * Lower half of a symmetric band matrix
240: *
241: K3 = KL + 1
242: K4 = N + 1
243: DO 110 J = 1, N
244: DO 100 I = 1, MIN( K3, K4-J )
245: A( I, J ) = A( I, J )*MUL
246: 100 CONTINUE
247: 110 CONTINUE
248: *
249: ELSE IF( ITYPE.EQ.5 ) THEN
250: *
251: * Upper half of a symmetric band matrix
252: *
253: K1 = KU + 2
254: K3 = KU + 1
255: DO 130 J = 1, N
256: DO 120 I = MAX( K1-J, 1 ), K3
257: A( I, J ) = A( I, J )*MUL
258: 120 CONTINUE
259: 130 CONTINUE
260: *
261: ELSE IF( ITYPE.EQ.6 ) THEN
262: *
263: * Band matrix
264: *
265: K1 = KL + KU + 2
266: K2 = KL + 1
267: K3 = 2*KL + KU + 1
268: K4 = KL + KU + 1 + M
269: DO 150 J = 1, N
270: DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
271: A( I, J ) = A( I, J )*MUL
272: 140 CONTINUE
273: 150 CONTINUE
274: *
275: END IF
276: *
277: IF( .NOT.DONE )
278: $ GO TO 10
279: *
280: RETURN
281: *
282: * End of ZLASCL
283: *
284: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zlascl.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack