1 SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
2 *
3 * -- LAPACK auxiliary routine (version 3.3.0) --
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 2010
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 DOUBLE PRECISION A( LDA, * )
15 * ..
16 *
17 * Purpose
18 * =======
19 *
20 * DLASCL multiplies the M by N real 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. See DGBTRF for storage details.
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) DOUBLE PRECISION 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( 'DLASCL', -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 DLASCL
283 *
284 END
2 *
3 * -- LAPACK auxiliary routine (version 3.3.0) --
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 2010
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 DOUBLE PRECISION A( LDA, * )
15 * ..
16 *
17 * Purpose
18 * =======
19 *
20 * DLASCL multiplies the M by N real 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. See DGBTRF for storage details.
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) DOUBLE PRECISION 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( 'DLASCL', -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 DLASCL
283 *
284 END