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