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