1 | *> \brief \b SLASCL |
---|
2 | * |
---|
3 | * =========== DOCUMENTATION =========== |
---|
4 | * |
---|
5 | * Online html documentation available at |
---|
6 | * http://www.netlib.org/lapack/explore-html/ |
---|
7 | * |
---|
8 | *> \htmlonly |
---|
9 | *> Download SLASCL + dependencies |
---|
10 | *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slascl.f"> |
---|
11 | *> [TGZ]</a> |
---|
12 | *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slascl.f"> |
---|
13 | *> [ZIP]</a> |
---|
14 | *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slascl.f"> |
---|
15 | *> [TXT]</a> |
---|
16 | *> \endhtmlonly |
---|
17 | * |
---|
18 | * Definition: |
---|
19 | * =========== |
---|
20 | * |
---|
21 | * SUBROUTINE SLASCL( 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 | * REAL CFROM, CTO |
---|
27 | * .. |
---|
28 | * .. Array Arguments .. |
---|
29 | * REAL A( LDA, * ) |
---|
30 | * .. |
---|
31 | * |
---|
32 | * |
---|
33 | *> \par Purpose: |
---|
34 | * ============= |
---|
35 | *> |
---|
36 | *> \verbatim |
---|
37 | *> |
---|
38 | *> SLASCL 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 SGBTRF 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 REAL |
---|
83 | *> \endverbatim |
---|
84 | *> |
---|
85 | *> \param[in] CTO |
---|
86 | *> \verbatim |
---|
87 | *> CTO is REAL |
---|
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 REAL 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 | * |
---|
135 | *> \date November 2011 |
---|
136 | * |
---|
137 | *> \ingroup auxOTHERauxiliary |
---|
138 | * |
---|
139 | * ===================================================================== |
---|
140 | SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) |
---|
141 | * |
---|
142 | * -- LAPACK auxiliary routine (version 3.4.0) -- |
---|
143 | * -- LAPACK is a software package provided by Univ. of Tennessee, -- |
---|
144 | * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
---|
145 | * November 2011 |
---|
146 | * |
---|
147 | * .. Scalar Arguments .. |
---|
148 | CHARACTER TYPE |
---|
149 | INTEGER INFO, KL, KU, LDA, M, N |
---|
150 | REAL CFROM, CTO |
---|
151 | * .. |
---|
152 | * .. Array Arguments .. |
---|
153 | REAL A( LDA, * ) |
---|
154 | * .. |
---|
155 | * |
---|
156 | * ===================================================================== |
---|
157 | * |
---|
158 | * .. Parameters .. |
---|
159 | REAL ZERO, ONE |
---|
160 | PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) |
---|
161 | * .. |
---|
162 | * .. Local Scalars .. |
---|
163 | LOGICAL DONE |
---|
164 | INTEGER I, ITYPE, J, K1, K2, K3, K4 |
---|
165 | REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM |
---|
166 | * .. |
---|
167 | * .. External Functions .. |
---|
168 | LOGICAL LSAME, SISNAN |
---|
169 | REAL SLAMCH |
---|
170 | EXTERNAL LSAME, SLAMCH, SISNAN |
---|
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. SISNAN(CFROM) ) THEN |
---|
205 | INFO = -4 |
---|
206 | ELSE IF( SISNAN(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( 'SLASCL', -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 = SLAMCH( '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 SLASCL |
---|
363 | * |
---|
364 | END |
---|