github.com/gonum/lapack@v0.0.0-20181123203213-e4cdc5a0bff9/internal/testdata/dsterftest/dlascl.f (about) 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 9 *> Download DLASCL + dependencies 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. 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 DLASCL( 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 DOUBLE PRECISION CFROM, CTO 151 * .. 152 * .. Array Arguments .. 153 DOUBLE PRECISION A( LDA, * ) 154 * .. 155 * 156 * ===================================================================== 157 * 158 * .. Parameters .. 159 DOUBLE PRECISION ZERO, ONE 160 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 161 * .. 162 * .. Local Scalars .. 163 LOGICAL DONE 164 INTEGER I, ITYPE, J, K1, K2, K3, K4 165 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM 166 * .. 167 * .. External Functions .. 168 LOGICAL LSAME, DISNAN 169 DOUBLE PRECISION DLAMCH 170 EXTERNAL LSAME, DLAMCH, DISNAN 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. DISNAN(CFROM) ) THEN 205 INFO = -4 206 ELSE IF( DISNAN(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( 'DLASCL', -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 = DLAMCH( '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 DLASCL 363 * 364 END