1*> \brief \b SLASCL 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 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 September 2012 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.2) -- 143* -- LAPACK is a software package provided by Univ. of Tennessee, -- 144* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 145* September 2012 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 365c $Id$ 366