1*> \brief \b CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download CLASCL + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clascl.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clascl.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clascl.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18*  Definition:
19*  ===========
20*
21*       SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
22*
23*       .. Scalar Arguments ..
24*       CHARACTER          TYPE
25*       INTEGER            INFO, KL, KU, LDA, M, N
26*       REAL               CFROM, CTO
27*       ..
28*       .. Array Arguments ..
29*       COMPLEX            A( LDA, * )
30*       ..
31*
32*
33*> \par Purpose:
34*  =============
35*>
36*> \verbatim
37*>
38*> CLASCL multiplies the M by N complex matrix A by the real scalar
39*> CTO/CFROM.  This is done without over/underflow as long as the final
40*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
41*> A may be full, upper triangular, lower triangular, upper Hessenberg,
42*> or banded.
43*> \endverbatim
44*
45*  Arguments:
46*  ==========
47*
48*> \param[in] TYPE
49*> \verbatim
50*>          TYPE is CHARACTER*1
51*>          TYPE indices the storage type of the input matrix.
52*>          = 'G':  A is a full matrix.
53*>          = 'L':  A is a lower triangular matrix.
54*>          = 'U':  A is an upper triangular matrix.
55*>          = 'H':  A is an upper Hessenberg matrix.
56*>          = 'B':  A is a symmetric band matrix with lower bandwidth KL
57*>                  and upper bandwidth KU and with the only the lower
58*>                  half stored.
59*>          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
60*>                  and upper bandwidth KU and with the only the upper
61*>                  half stored.
62*>          = 'Z':  A is a band matrix with lower bandwidth KL and upper
63*>                  bandwidth KU. See CGBTRF for storage details.
64*> \endverbatim
65*>
66*> \param[in] KL
67*> \verbatim
68*>          KL is INTEGER
69*>          The lower bandwidth of A.  Referenced only if TYPE = 'B',
70*>          'Q' or 'Z'.
71*> \endverbatim
72*>
73*> \param[in] KU
74*> \verbatim
75*>          KU is INTEGER
76*>          The upper bandwidth of A.  Referenced only if TYPE = 'B',
77*>          'Q' or 'Z'.
78*> \endverbatim
79*>
80*> \param[in] CFROM
81*> \verbatim
82*>          CFROM is REAL
83*> \endverbatim
84*>
85*> \param[in] CTO
86*> \verbatim
87*>          CTO is REAL
88*>
89*>          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
90*>          without over/underflow if the final result CTO*A(I,J)/CFROM
91*>          can be represented without over/underflow.  CFROM must be
92*>          nonzero.
93*> \endverbatim
94*>
95*> \param[in] M
96*> \verbatim
97*>          M is INTEGER
98*>          The number of rows of the matrix A.  M >= 0.
99*> \endverbatim
100*>
101*> \param[in] N
102*> \verbatim
103*>          N is INTEGER
104*>          The number of columns of the matrix A.  N >= 0.
105*> \endverbatim
106*>
107*> \param[in,out] A
108*> \verbatim
109*>          A is COMPLEX array, dimension (LDA,N)
110*>          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
111*>          storage type.
112*> \endverbatim
113*>
114*> \param[in] LDA
115*> \verbatim
116*>          LDA is INTEGER
117*>          The leading dimension of the array A.
118*>          If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M);
119*>             TYPE = 'B', LDA >= KL+1;
120*>             TYPE = 'Q', LDA >= KU+1;
121*>             TYPE = 'Z', LDA >= 2*KL+KU+1.
122*> \endverbatim
123*>
124*> \param[out] INFO
125*> \verbatim
126*>          INFO is INTEGER
127*>          0  - successful exit
128*>          <0 - if INFO = -i, the i-th argument had an illegal value.
129*> \endverbatim
130*
131*  Authors:
132*  ========
133*
134*> \author Univ. of Tennessee
135*> \author Univ. of California Berkeley
136*> \author Univ. of Colorado Denver
137*> \author NAG Ltd.
138*
139*> \date June 2016
140*
141*> \ingroup complexOTHERauxiliary
142*
143*  =====================================================================
144      SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
145*
146*  -- LAPACK auxiliary routine (version 3.7.0) --
147*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
148*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
149*     June 2016
150*
151*     .. Scalar Arguments ..
152      CHARACTER          TYPE
153      INTEGER            INFO, KL, KU, LDA, M, N
154      REAL               CFROM, CTO
155*     ..
156*     .. Array Arguments ..
157      COMPLEX            A( LDA, * )
158*     ..
159*
160*  =====================================================================
161*
162*     .. Parameters ..
163      REAL               ZERO, ONE
164      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
165*     ..
166*     .. Local Scalars ..
167      LOGICAL            DONE
168      INTEGER            I, ITYPE, J, K1, K2, K3, K4
169      REAL               BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
170*     ..
171*     .. External Functions ..
172      LOGICAL            LSAME, SISNAN
173      REAL               SLAMCH
174      EXTERNAL           LSAME, SLAMCH, SISNAN
175*     ..
176*     .. Intrinsic Functions ..
177      INTRINSIC          ABS, MAX, MIN
178*     ..
179*     .. External Subroutines ..
180      EXTERNAL           XERBLA
181*     ..
182*     .. Executable Statements ..
183*
184*     Test the input arguments
185*
186      INFO = 0
187*
188      IF( LSAME( TYPE, 'G' ) ) THEN
189         ITYPE = 0
190      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
191         ITYPE = 1
192      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
193         ITYPE = 2
194      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
195         ITYPE = 3
196      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
197         ITYPE = 4
198      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
199         ITYPE = 5
200      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
201         ITYPE = 6
202      ELSE
203         ITYPE = -1
204      END IF
205*
206      IF( ITYPE.EQ.-1 ) THEN
207         INFO = -1
208      ELSE IF( CFROM.EQ.ZERO .OR. SISNAN(CFROM) ) THEN
209         INFO = -4
210      ELSE IF( SISNAN(CTO) ) THEN
211         INFO = -5
212      ELSE IF( M.LT.0 ) THEN
213         INFO = -6
214      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
215     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
216         INFO = -7
217      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
218         INFO = -9
219      ELSE IF( ITYPE.GE.4 ) THEN
220         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
221            INFO = -2
222         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
223     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
224     $             THEN
225            INFO = -3
226         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
227     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
228     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
229            INFO = -9
230         END IF
231      END IF
232*
233      IF( INFO.NE.0 ) THEN
234         CALL XERBLA( 'CLASCL', -INFO )
235         RETURN
236      END IF
237*
238*     Quick return if possible
239*
240      IF( N.EQ.0 .OR. M.EQ.0 )
241     $   RETURN
242*
243*     Get machine parameters
244*
245      SMLNUM = SLAMCH( 'S' )
246      BIGNUM = ONE / SMLNUM
247*
248      CFROMC = CFROM
249      CTOC = CTO
250*
251   10 CONTINUE
252      CFROM1 = CFROMC*SMLNUM
253      IF( CFROM1.EQ.CFROMC ) THEN
254!        CFROMC is an inf.  Multiply by a correctly signed zero for
255!        finite CTOC, or a NaN if CTOC is infinite.
256         MUL = CTOC / CFROMC
257         DONE = .TRUE.
258         CTO1 = CTOC
259      ELSE
260         CTO1 = CTOC / BIGNUM
261         IF( CTO1.EQ.CTOC ) THEN
262!           CTOC is either 0 or an inf.  In both cases, CTOC itself
263!           serves as the correct multiplication factor.
264            MUL = CTOC
265            DONE = .TRUE.
266            CFROMC = ONE
267         ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
268            MUL = SMLNUM
269            DONE = .FALSE.
270            CFROMC = CFROM1
271         ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
272            MUL = BIGNUM
273            DONE = .FALSE.
274            CTOC = CTO1
275         ELSE
276            MUL = CTOC / CFROMC
277            DONE = .TRUE.
278         END IF
279      END IF
280*
281      IF( ITYPE.EQ.0 ) THEN
282*
283*        Full matrix
284*
285         DO 30 J = 1, N
286            DO 20 I = 1, M
287               A( I, J ) = A( I, J )*MUL
288   20       CONTINUE
289   30    CONTINUE
290*
291      ELSE IF( ITYPE.EQ.1 ) THEN
292*
293*        Lower triangular matrix
294*
295         DO 50 J = 1, N
296            DO 40 I = J, M
297               A( I, J ) = A( I, J )*MUL
298   40       CONTINUE
299   50    CONTINUE
300*
301      ELSE IF( ITYPE.EQ.2 ) THEN
302*
303*        Upper triangular matrix
304*
305         DO 70 J = 1, N
306            DO 60 I = 1, MIN( J, M )
307               A( I, J ) = A( I, J )*MUL
308   60       CONTINUE
309   70    CONTINUE
310*
311      ELSE IF( ITYPE.EQ.3 ) THEN
312*
313*        Upper Hessenberg matrix
314*
315         DO 90 J = 1, N
316            DO 80 I = 1, MIN( J+1, M )
317               A( I, J ) = A( I, J )*MUL
318   80       CONTINUE
319   90    CONTINUE
320*
321      ELSE IF( ITYPE.EQ.4 ) THEN
322*
323*        Lower half of a symmetric band matrix
324*
325         K3 = KL + 1
326         K4 = N + 1
327         DO 110 J = 1, N
328            DO 100 I = 1, MIN( K3, K4-J )
329               A( I, J ) = A( I, J )*MUL
330  100       CONTINUE
331  110    CONTINUE
332*
333      ELSE IF( ITYPE.EQ.5 ) THEN
334*
335*        Upper half of a symmetric band matrix
336*
337         K1 = KU + 2
338         K3 = KU + 1
339         DO 130 J = 1, N
340            DO 120 I = MAX( K1-J, 1 ), K3
341               A( I, J ) = A( I, J )*MUL
342  120       CONTINUE
343  130    CONTINUE
344*
345      ELSE IF( ITYPE.EQ.6 ) THEN
346*
347*        Band matrix
348*
349         K1 = KL + KU + 2
350         K2 = KL + 1
351         K3 = 2*KL + KU + 1
352         K4 = KL + KU + 1 + M
353         DO 150 J = 1, N
354            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
355               A( I, J ) = A( I, J )*MUL
356  140       CONTINUE
357  150    CONTINUE
358*
359      END IF
360*
361      IF( .NOT.DONE )
362     $   GO TO 10
363*
364      RETURN
365*
366*     End of CLASCL
367*
368      END
369