001: SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) 002: * 003: * -- LAPACK auxiliary routine (version 3.2) -- 004: * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 005: * November 2006 006: * 007: * .. Scalar Arguments .. 008: CHARACTER TYPE 009: INTEGER INFO, KL, KU, LDA, M, N 010: DOUBLE PRECISION CFROM, CTO 011: * .. 012: * .. Array Arguments .. 013: DOUBLE PRECISION A( LDA, * ) 014: * .. 015: * 016: * Purpose 017: * ======= 018: * 019: * DLASCL multiplies the M by N real matrix A by the real scalar 020: * CTO/CFROM. This is done without over/underflow as long as the final 021: * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that 022: * A may be full, upper triangular, lower triangular, upper Hessenberg, 023: * or banded. 024: * 025: * Arguments 026: * ========= 027: * 028: * TYPE (input) CHARACTER*1 029: * TYPE indices the storage type of the input matrix. 030: * = 'G': A is a full matrix. 031: * = 'L': A is a lower triangular matrix. 032: * = 'U': A is an upper triangular matrix. 033: * = 'H': A is an upper Hessenberg matrix. 034: * = 'B': A is a symmetric band matrix with lower bandwidth KL 035: * and upper bandwidth KU and with the only the lower 036: * half stored. 037: * = 'Q': A is a symmetric band matrix with lower bandwidth KL 038: * and upper bandwidth KU and with the only the upper 039: * half stored. 040: * = 'Z': A is a band matrix with lower bandwidth KL and upper 041: * bandwidth KU. 042: * 043: * KL (input) INTEGER 044: * The lower bandwidth of A. Referenced only if TYPE = 'B', 045: * 'Q' or 'Z'. 046: * 047: * KU (input) INTEGER 048: * The upper bandwidth of A. Referenced only if TYPE = 'B', 049: * 'Q' or 'Z'. 050: * 051: * CFROM (input) DOUBLE PRECISION 052: * CTO (input) DOUBLE PRECISION 053: * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed 054: * without over/underflow if the final result CTO*A(I,J)/CFROM 055: * can be represented without over/underflow. CFROM must be 056: * nonzero. 057: * 058: * M (input) INTEGER 059: * The number of rows of the matrix A. M >= 0. 060: * 061: * N (input) INTEGER 062: * The number of columns of the matrix A. N >= 0. 063: * 064: * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) 065: * The matrix to be multiplied by CTO/CFROM. See TYPE for the 066: * storage type. 067: * 068: * LDA (input) INTEGER 069: * The leading dimension of the array A. LDA >= max(1,M). 070: * 071: * INFO (output) INTEGER 072: * 0 - successful exit 073: * <0 - if INFO = -i, the i-th argument had an illegal value. 074: * 075: * ===================================================================== 076: * 077: * .. Parameters .. 078: DOUBLE PRECISION ZERO, ONE 079: PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 080: * .. 081: * .. Local Scalars .. 082: LOGICAL DONE 083: INTEGER I, ITYPE, J, K1, K2, K3, K4 084: DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM 085: * .. 086: * .. External Functions .. 087: LOGICAL LSAME, DISNAN 088: DOUBLE PRECISION DLAMCH 089: EXTERNAL LSAME, DLAMCH, DISNAN 090: * .. 091: * .. Intrinsic Functions .. 092: INTRINSIC ABS, MAX, MIN 093: * .. 094: * .. External Subroutines .. 095: EXTERNAL XERBLA 096: * .. 097: * .. Executable Statements .. 098: * 099: * 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 .OR. DISNAN(CFROM) ) THEN 124: INFO = -4 125: ELSE IF( DISNAN(CTO) ) THEN 126: INFO = -5 127: ELSE IF( M.LT.0 ) THEN 128: INFO = -6 129: ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. 130: $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN 131: INFO = -7 132: ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN 133: INFO = -9 134: ELSE IF( ITYPE.GE.4 ) THEN 135: IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN 136: INFO = -2 137: ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. 138: $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) 139: $ THEN 140: INFO = -3 141: ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. 142: $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. 143: $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN 144: INFO = -9 145: END IF 146: END IF 147: * 148: IF( INFO.NE.0 ) THEN 149: CALL XERBLA( 'DLASCL', -INFO ) 150: RETURN 151: END IF 152: * 153: * Quick return if possible 154: * 155: IF( N.EQ.0 .OR. M.EQ.0 ) 156: $ RETURN 157: * 158: * Get machine parameters 159: * 160: SMLNUM = DLAMCH( 'S' ) 161: BIGNUM = ONE / SMLNUM 162: * 163: CFROMC = CFROM 164: CTOC = CTO 165: * 166: 10 CONTINUE 167: CFROM1 = CFROMC*SMLNUM 168: IF( CFROM1.EQ.CFROMC ) THEN 169: ! CFROMC is an inf. Multiply by a correctly signed zero for 170: ! finite CTOC, or a NaN if CTOC is infinite. 171: MUL = CTOC / CFROMC 172: DONE = .TRUE. 173: CTO1 = CTOC 174: ELSE 175: CTO1 = CTOC / BIGNUM 176: IF( CTO1.EQ.CTOC ) THEN 177: ! CTOC is either 0 or an inf. In both cases, CTOC itself 178: ! serves as the correct multiplication factor. 179: MUL = CTOC 180: DONE = .TRUE. 181: CFROMC = ONE 182: ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN 183: MUL = SMLNUM 184: DONE = .FALSE. 185: CFROMC = CFROM1 186: ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN 187: MUL = BIGNUM 188: DONE = .FALSE. 189: CTOC = CTO1 190: ELSE 191: MUL = CTOC / CFROMC 192: DONE = .TRUE. 193: END IF 194: END IF 195: * 196: IF( ITYPE.EQ.0 ) THEN 197: * 198: * Full matrix 199: * 200: DO 30 J = 1, N 201: DO 20 I = 1, M 202: A( I, J ) = A( I, J )*MUL 203: 20 CONTINUE 204: 30 CONTINUE 205: * 206: ELSE IF( ITYPE.EQ.1 ) THEN 207: * 208: * Lower triangular matrix 209: * 210: DO 50 J = 1, N 211: DO 40 I = J, M 212: A( I, J ) = A( I, J )*MUL 213: 40 CONTINUE 214: 50 CONTINUE 215: * 216: ELSE IF( ITYPE.EQ.2 ) THEN 217: * 218: * Upper triangular matrix 219: * 220: DO 70 J = 1, N 221: DO 60 I = 1, MIN( J, M ) 222: A( I, J ) = A( I, J )*MUL 223: 60 CONTINUE 224: 70 CONTINUE 225: * 226: ELSE IF( ITYPE.EQ.3 ) THEN 227: * 228: * Upper Hessenberg matrix 229: * 230: DO 90 J = 1, N 231: DO 80 I = 1, MIN( J+1, M ) 232: A( I, J ) = A( I, J )*MUL 233: 80 CONTINUE 234: 90 CONTINUE 235: * 236: ELSE IF( ITYPE.EQ.4 ) THEN 237: * 238: * Lower half of a symmetric band matrix 239: * 240: K3 = KL + 1 241: K4 = N + 1 242: DO 110 J = 1, N 243: DO 100 I = 1, MIN( K3, K4-J ) 244: A( I, J ) = A( I, J )*MUL 245: 100 CONTINUE 246: 110 CONTINUE 247: * 248: ELSE IF( ITYPE.EQ.5 ) THEN 249: * 250: * Upper half of a symmetric band matrix 251: * 252: K1 = KU + 2 253: K3 = KU + 1 254: DO 130 J = 1, N 255: DO 120 I = MAX( K1-J, 1 ), K3 256: A( I, J ) = A( I, J )*MUL 257: 120 CONTINUE 258: 130 CONTINUE 259: * 260: ELSE IF( ITYPE.EQ.6 ) THEN 261: * 262: * Band matrix 263: * 264: K1 = KL + KU + 2 265: K2 = KL + 1 266: K3 = 2*KL + KU + 1 267: K4 = KL + KU + 1 + M 268: DO 150 J = 1, N 269: DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) 270: A( I, J ) = A( I, J )*MUL 271: 140 CONTINUE 272: 150 CONTINUE 273: * 274: END IF 275: * 276: IF( .NOT.DONE ) 277: $ GO TO 10 278: * 279: RETURN 280: * 281: * End of DLASCL 282: * 283: END 284: