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