1*> \brief \b DLASCL 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 DLASCL + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlascl.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlascl.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlascl.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18*  Definition:
19*  ===========
20*
21*       SUBROUTINE DLASCL( 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*       DOUBLE PRECISION   CFROM, CTO
27*       ..
28*       .. Array Arguments ..
29*       DOUBLE PRECISION   A( LDA, * )
30*       ..
31*
32*
33*> \par Purpose:
34*  =============
35*>
36*> \verbatim
37*>
38*> DLASCL multiplies the M by N real 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 DGBTRF 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 DOUBLE PRECISION
83*> \endverbatim
84*>
85*> \param[in] CTO
86*> \verbatim
87*>          CTO is DOUBLE PRECISION
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 DOUBLE PRECISION 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.  LDA >= max(1,M).
118*> \endverbatim
119*>
120*> \param[out] INFO
121*> \verbatim
122*>          INFO is INTEGER
123*>          0  - successful exit
124*>          <0 - if INFO = -i, the i-th argument had an illegal value.
125*> \endverbatim
126*
127*  Authors:
128*  ========
129*
130*> \author Univ. of Tennessee
131*> \author Univ. of California Berkeley
132*> \author Univ. of Colorado Denver
133*> \author NAG Ltd.
134*
135*> \date September 2012
136*
137*> \ingroup auxOTHERauxiliary
138*
139*  =====================================================================
140      SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
141*
142*  -- LAPACK auxiliary routine (version 3.4.2) --
143*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
144*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
145*     September 2012
146*
147*     .. Scalar Arguments ..
148      CHARACTER          TYPE
149      INTEGER            INFO, KL, KU, LDA, M, N
150      DOUBLE PRECISION   CFROM, CTO
151*     ..
152*     .. Array Arguments ..
153      DOUBLE PRECISION   A( LDA, * )
154*     ..
155*
156*  =====================================================================
157*
158*     .. Parameters ..
159      DOUBLE PRECISION   ZERO, ONE
160      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
161*     ..
162*     .. Local Scalars ..
163      LOGICAL            DONE
164      INTEGER            I, ITYPE, J, K1, K2, K3, K4
165      DOUBLE PRECISION   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
166*     ..
167*     .. External Functions ..
168      LOGICAL            LSAME, DISNAN
169      DOUBLE PRECISION   DLAMCH
170      EXTERNAL           LSAME, DLAMCH, DISNAN
171*     ..
172*     .. Intrinsic Functions ..
173      INTRINSIC          ABS, MAX, MIN
174*     ..
175*     .. External Subroutines ..
176      EXTERNAL           XERBLA
177*     ..
178*     .. Executable Statements ..
179*
180*     Test the input arguments
181*
182      INFO = 0
183*
184      IF( LSAME( TYPE, 'G' ) ) THEN
185         ITYPE = 0
186      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
187         ITYPE = 1
188      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
189         ITYPE = 2
190      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
191         ITYPE = 3
192      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
193         ITYPE = 4
194      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
195         ITYPE = 5
196      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
197         ITYPE = 6
198      ELSE
199         ITYPE = -1
200      END IF
201*
202      IF( ITYPE.EQ.-1 ) THEN
203         INFO = -1
204      ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
205         INFO = -4
206      ELSE IF( DISNAN(CTO) ) THEN
207         INFO = -5
208      ELSE IF( M.LT.0 ) THEN
209         INFO = -6
210      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
211     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
212         INFO = -7
213      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
214         INFO = -9
215      ELSE IF( ITYPE.GE.4 ) THEN
216         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
217            INFO = -2
218         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
219     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
220     $             THEN
221            INFO = -3
222         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
223     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
224     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
225            INFO = -9
226         END IF
227      END IF
228*
229      IF( INFO.NE.0 ) THEN
230         CALL XERBLA( 'DLASCL', -INFO )
231         RETURN
232      END IF
233*
234*     Quick return if possible
235*
236      IF( N.EQ.0 .OR. M.EQ.0 )
237     $   RETURN
238*
239*     Get machine parameters
240*
241      SMLNUM = DLAMCH( 'S' )
242      BIGNUM = ONE / SMLNUM
243*
244      CFROMC = CFROM
245      CTOC = CTO
246*
247   10 CONTINUE
248      CFROM1 = CFROMC*SMLNUM
249      IF( CFROM1.EQ.CFROMC ) THEN
250!        CFROMC is an inf.  Multiply by a correctly signed zero for
251!        finite CTOC, or a NaN if CTOC is infinite.
252         MUL = CTOC / CFROMC
253         DONE = .TRUE.
254         CTO1 = CTOC
255      ELSE
256         CTO1 = CTOC / BIGNUM
257         IF( CTO1.EQ.CTOC ) THEN
258!           CTOC is either 0 or an inf.  In both cases, CTOC itself
259!           serves as the correct multiplication factor.
260            MUL = CTOC
261            DONE = .TRUE.
262            CFROMC = ONE
263         ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
264            MUL = SMLNUM
265            DONE = .FALSE.
266            CFROMC = CFROM1
267         ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
268            MUL = BIGNUM
269            DONE = .FALSE.
270            CTOC = CTO1
271         ELSE
272            MUL = CTOC / CFROMC
273            DONE = .TRUE.
274         END IF
275      END IF
276*
277      IF( ITYPE.EQ.0 ) THEN
278*
279*        Full matrix
280*
281         DO 30 J = 1, N
282            DO 20 I = 1, M
283               A( I, J ) = A( I, J )*MUL
284   20       CONTINUE
285   30    CONTINUE
286*
287      ELSE IF( ITYPE.EQ.1 ) THEN
288*
289*        Lower triangular matrix
290*
291         DO 50 J = 1, N
292            DO 40 I = J, M
293               A( I, J ) = A( I, J )*MUL
294   40       CONTINUE
295   50    CONTINUE
296*
297      ELSE IF( ITYPE.EQ.2 ) THEN
298*
299*        Upper triangular matrix
300*
301         DO 70 J = 1, N
302            DO 60 I = 1, MIN( J, M )
303               A( I, J ) = A( I, J )*MUL
304   60       CONTINUE
305   70    CONTINUE
306*
307      ELSE IF( ITYPE.EQ.3 ) THEN
308*
309*        Upper Hessenberg matrix
310*
311         DO 90 J = 1, N
312            DO 80 I = 1, MIN( J+1, M )
313               A( I, J ) = A( I, J )*MUL
314   80       CONTINUE
315   90    CONTINUE
316*
317      ELSE IF( ITYPE.EQ.4 ) THEN
318*
319*        Lower half of a symmetric band matrix
320*
321         K3 = KL + 1
322         K4 = N + 1
323         DO 110 J = 1, N
324            DO 100 I = 1, MIN( K3, K4-J )
325               A( I, J ) = A( I, J )*MUL
326  100       CONTINUE
327  110    CONTINUE
328*
329      ELSE IF( ITYPE.EQ.5 ) THEN
330*
331*        Upper half of a symmetric band matrix
332*
333         K1 = KU + 2
334         K3 = KU + 1
335         DO 130 J = 1, N
336            DO 120 I = MAX( K1-J, 1 ), K3
337               A( I, J ) = A( I, J )*MUL
338  120       CONTINUE
339  130    CONTINUE
340*
341      ELSE IF( ITYPE.EQ.6 ) THEN
342*
343*        Band matrix
344*
345         K1 = KL + KU + 2
346         K2 = KL + 1
347         K3 = 2*KL + KU + 1
348         K4 = KL + KU + 1 + M
349         DO 150 J = 1, N
350            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
351               A( I, J ) = A( I, J )*MUL
352  140       CONTINUE
353  150    CONTINUE
354*
355      END IF
356*
357      IF( .NOT.DONE )
358     $   GO TO 10
359*
360      RETURN
361*
362*     End of DLASCL
363*
364      END
365c $Id$
366