1 SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) 2* 3* -- LAPACK auxiliary routine (version 3.0) -- 4* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 5* Courant Institute, Argonne National Lab, and Rice University 6* February 29, 1992 7* 8* .. Scalar Arguments .. 9 CHARACTER TYPE 10 INTEGER INFO, KL, KU, LDA, M, N 11 REAL CFROM, CTO 12* .. 13* .. Array Arguments .. 14 COMPLEX A( LDA, * ) 15* .. 16* 17* Purpose 18* ======= 19* 20* CLASCL multiplies the M by N complex matrix A by the real scalar 21* CTO/CFROM. This is done without over/underflow as long as the final 22* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that 23* A may be full, upper triangular, lower triangular, upper Hessenberg, 24* or banded. 25* 26* Arguments 27* ========= 28* 29* TYPE (input) CHARACTER*1 30* TYPE indices the storage type of the input matrix. 31* = 'G': A is a full matrix. 32* = 'L': A is a lower triangular matrix. 33* = 'U': A is an upper triangular matrix. 34* = 'H': A is an upper Hessenberg matrix. 35* = 'B': A is a symmetric band matrix with lower bandwidth KL 36* and upper bandwidth KU and with the only the lower 37* half stored. 38* = 'Q': A is a symmetric band matrix with lower bandwidth KL 39* and upper bandwidth KU and with the only the upper 40* half stored. 41* = 'Z': A is a band matrix with lower bandwidth KL and upper 42* bandwidth KU. 43* 44* KL (input) INTEGER 45* The lower bandwidth of A. Referenced only if TYPE = 'B', 46* 'Q' or 'Z'. 47* 48* KU (input) INTEGER 49* The upper bandwidth of A. Referenced only if TYPE = 'B', 50* 'Q' or 'Z'. 51* 52* CFROM (input) REAL 53* CTO (input) REAL 54* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed 55* without over/underflow if the final result CTO*A(I,J)/CFROM 56* can be represented without over/underflow. CFROM must be 57* nonzero. 58* 59* M (input) INTEGER 60* The number of rows of the matrix A. M >= 0. 61* 62* N (input) INTEGER 63* The number of columns of the matrix A. N >= 0. 64* 65* A (input/output) COMPLEX array, dimension (LDA,M) 66* The matrix to be multiplied by CTO/CFROM. See TYPE for the 67* storage type. 68* 69* LDA (input) INTEGER 70* The leading dimension of the array A. LDA >= max(1,M). 71* 72* INFO (output) INTEGER 73* 0 - successful exit 74* <0 - if INFO = -i, the i-th argument had an illegal value. 75* 76* ===================================================================== 77* 78* .. Parameters .. 79 REAL ZERO, ONE 80 PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) 81* .. 82* .. Local Scalars .. 83 LOGICAL DONE 84 INTEGER I, ITYPE, J, K1, K2, K3, K4 85 REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM 86* .. 87* .. External Functions .. 88 LOGICAL LSAME 89 REAL SLAMCH 90 EXTERNAL LSAME, SLAMCH 91* .. 92* .. Intrinsic Functions .. 93 INTRINSIC ABS, MAX, MIN 94* .. 95* .. External Subroutines .. 96 EXTERNAL XERBLA 97* .. 98* .. Executable Statements .. 99* 100* Test the input arguments 101* 102 INFO = 0 103* 104 IF( LSAME( TYPE, 'G' ) ) THEN 105 ITYPE = 0 106 ELSE IF( LSAME( TYPE, 'L' ) ) THEN 107 ITYPE = 1 108 ELSE IF( LSAME( TYPE, 'U' ) ) THEN 109 ITYPE = 2 110 ELSE IF( LSAME( TYPE, 'H' ) ) THEN 111 ITYPE = 3 112 ELSE IF( LSAME( TYPE, 'B' ) ) THEN 113 ITYPE = 4 114 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN 115 ITYPE = 5 116 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN 117 ITYPE = 6 118 ELSE 119 ITYPE = -1 120 END IF 121* 122 IF( ITYPE.EQ.-1 ) THEN 123 INFO = -1 124 ELSE IF( CFROM.EQ.ZERO ) THEN 125 INFO = -4 126 ELSE IF( M.LT.0 ) THEN 127 INFO = -6 128 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. 129 $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN 130 INFO = -7 131 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN 132 INFO = -9 133 ELSE IF( ITYPE.GE.4 ) THEN 134 IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN 135 INFO = -2 136 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. 137 $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) 138 $ THEN 139 INFO = -3 140 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. 141 $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. 142 $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN 143 INFO = -9 144 END IF 145 END IF 146* 147 IF( INFO.NE.0 ) THEN 148 CALL XERBLA( 'CLASCL', -INFO ) 149 RETURN 150 END IF 151* 152* Quick return if possible 153* 154 IF( N.EQ.0 .OR. M.EQ.0 ) 155 $ RETURN 156* 157* Get machine parameters 158* 159 SMLNUM = SLAMCH( 'S' ) 160 BIGNUM = ONE / SMLNUM 161* 162 CFROMC = CFROM 163 CTOC = CTO 164* 165 10 CONTINUE 166 CFROM1 = CFROMC*SMLNUM 167 CTO1 = CTOC / BIGNUM 168 IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN 169 MUL = SMLNUM 170 DONE = .FALSE. 171 CFROMC = CFROM1 172 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN 173 MUL = BIGNUM 174 DONE = .FALSE. 175 CTOC = CTO1 176 ELSE 177 MUL = CTOC / CFROMC 178 DONE = .TRUE. 179 END IF 180* 181 IF( ITYPE.EQ.0 ) THEN 182* 183* Full matrix 184* 185 DO 30 J = 1, N 186 DO 20 I = 1, M 187 A( I, J ) = A( I, J )*MUL 188 20 CONTINUE 189 30 CONTINUE 190* 191 ELSE IF( ITYPE.EQ.1 ) THEN 192* 193* Lower triangular matrix 194* 195 DO 50 J = 1, N 196 DO 40 I = J, M 197 A( I, J ) = A( I, J )*MUL 198 40 CONTINUE 199 50 CONTINUE 200* 201 ELSE IF( ITYPE.EQ.2 ) THEN 202* 203* Upper triangular matrix 204* 205 DO 70 J = 1, N 206 DO 60 I = 1, MIN( J, M ) 207 A( I, J ) = A( I, J )*MUL 208 60 CONTINUE 209 70 CONTINUE 210* 211 ELSE IF( ITYPE.EQ.3 ) THEN 212* 213* Upper Hessenberg matrix 214* 215 DO 90 J = 1, N 216 DO 80 I = 1, MIN( J+1, M ) 217 A( I, J ) = A( I, J )*MUL 218 80 CONTINUE 219 90 CONTINUE 220* 221 ELSE IF( ITYPE.EQ.4 ) THEN 222* 223* Lower half of a symmetric band matrix 224* 225 K3 = KL + 1 226 K4 = N + 1 227 DO 110 J = 1, N 228 DO 100 I = 1, MIN( K3, K4-J ) 229 A( I, J ) = A( I, J )*MUL 230 100 CONTINUE 231 110 CONTINUE 232* 233 ELSE IF( ITYPE.EQ.5 ) THEN 234* 235* Upper half of a symmetric band matrix 236* 237 K1 = KU + 2 238 K3 = KU + 1 239 DO 130 J = 1, N 240 DO 120 I = MAX( K1-J, 1 ), K3 241 A( I, J ) = A( I, J )*MUL 242 120 CONTINUE 243 130 CONTINUE 244* 245 ELSE IF( ITYPE.EQ.6 ) THEN 246* 247* Band matrix 248* 249 K1 = KL + KU + 2 250 K2 = KL + 1 251 K3 = 2*KL + KU + 1 252 K4 = KL + KU + 1 + M 253 DO 150 J = 1, N 254 DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) 255 A( I, J ) = A( I, J )*MUL 256 140 CONTINUE 257 150 CONTINUE 258* 259 END IF 260* 261 IF( .NOT.DONE ) 262 $ GO TO 10 263* 264 RETURN 265* 266* End of CLASCL 267* 268 END 269