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: