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