LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ slascl()

subroutine slascl ( character type,
integer kl,
integer ku,
real cfrom,
real cto,
integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
integer info )

SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.

Download SLASCL + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> SLASCL multiplies the M by N real matrix A by the real scalar
!> CTO/CFROM.  This is done without over/underflow as long as the final
!> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
!> A may be full, upper triangular, lower triangular, upper Hessenberg,
!> or banded.
!>
Parameters
[in]TYPE
!>          TYPE is CHARACTER*1
!>          TYPE indices the storage type of the input matrix.
!>          = 'G':  A is a full matrix.
!>          = 'L':  A is a lower triangular matrix.
!>          = 'U':  A is an upper triangular matrix.
!>          = 'H':  A is an upper Hessenberg matrix.
!>          = 'B':  A is a symmetric band matrix with lower bandwidth KL
!>                  and upper bandwidth KU and with the only the lower
!>                  half stored.
!>          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
!>                  and upper bandwidth KU and with the only the upper
!>                  half stored.
!>          = 'Z':  A is a band matrix with lower bandwidth KL and upper
!>                  bandwidth KU. See SGBTRF for storage details.
!>
[in]KL
!>          KL is INTEGER
!>          The lower bandwidth of A.  Referenced only if TYPE = 'B',
!>          'Q' or 'Z'.
!>
[in]KU
!>          KU is INTEGER
!>          The upper bandwidth of A.  Referenced only if TYPE = 'B',
!>          'Q' or 'Z'.
!>
[in]CFROM
!>          CFROM is REAL
!>
[in]CTO
!>          CTO is REAL
!>
!>          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
!>          without over/underflow if the final result CTO*A(I,J)/CFROM
!>          can be represented without over/underflow.  CFROM must be
!>          nonzero.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
!>          storage type.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M);
!>             TYPE = 'B', LDA >= KL+1;
!>             TYPE = 'Q', LDA >= KU+1;
!>             TYPE = 'Z', LDA >= 2*KL+KU+1.
!>
[out]INFO
!>          INFO is INTEGER
!>          0  - successful exit
!>          <0 - if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 140 of file slascl.f.

142*
143* -- LAPACK auxiliary routine --
144* -- LAPACK is a software package provided by Univ. of Tennessee, --
145* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
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 IF (mul .EQ. one)
275 $ RETURN
276 END IF
277 END IF
278*
279 IF( itype.EQ.0 ) THEN
280*
281* Full matrix
282*
283 DO 30 j = 1, n
284 DO 20 i = 1, m
285 a( i, j ) = a( i, j )*mul
286 20 CONTINUE
287 30 CONTINUE
288*
289 ELSE IF( itype.EQ.1 ) THEN
290*
291* Lower triangular matrix
292*
293 DO 50 j = 1, n
294 DO 40 i = j, m
295 a( i, j ) = a( i, j )*mul
296 40 CONTINUE
297 50 CONTINUE
298*
299 ELSE IF( itype.EQ.2 ) THEN
300*
301* Upper triangular matrix
302*
303 DO 70 j = 1, n
304 DO 60 i = 1, min( j, m )
305 a( i, j ) = a( i, j )*mul
306 60 CONTINUE
307 70 CONTINUE
308*
309 ELSE IF( itype.EQ.3 ) THEN
310*
311* Upper Hessenberg matrix
312*
313 DO 90 j = 1, n
314 DO 80 i = 1, min( j+1, m )
315 a( i, j ) = a( i, j )*mul
316 80 CONTINUE
317 90 CONTINUE
318*
319 ELSE IF( itype.EQ.4 ) THEN
320*
321* Lower half of a symmetric band matrix
322*
323 k3 = kl + 1
324 k4 = n + 1
325 DO 110 j = 1, n
326 DO 100 i = 1, min( k3, k4-j )
327 a( i, j ) = a( i, j )*mul
328 100 CONTINUE
329 110 CONTINUE
330*
331 ELSE IF( itype.EQ.5 ) THEN
332*
333* Upper half of a symmetric band matrix
334*
335 k1 = ku + 2
336 k3 = ku + 1
337 DO 130 j = 1, n
338 DO 120 i = max( k1-j, 1 ), k3
339 a( i, j ) = a( i, j )*mul
340 120 CONTINUE
341 130 CONTINUE
342*
343 ELSE IF( itype.EQ.6 ) THEN
344*
345* Band matrix
346*
347 k1 = kl + ku + 2
348 k2 = kl + 1
349 k3 = 2*kl + ku + 1
350 k4 = kl + ku + 1 + m
351 DO 150 j = 1, n
352 DO 140 i = max( k1-j, k2 ), min( k3, k4-j )
353 a( i, j ) = a( i, j )*mul
354 140 CONTINUE
355 150 CONTINUE
356*
357 END IF
358*
359 IF( .NOT.done )
360 $ GO TO 10
361*
362 RETURN
363*
364* End of SLASCL
365*
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
sisnan
logical function sisnan(sin)
SISNAN tests input for NaN.
Definition sisnan.f:57
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
Here is the call graph for this function:
Here is the caller graph for this function: