1 SUBROUTINE ZLASCL
( TYPE
, KL
, KU
, CFROM
, CTO
, M
, N
, A
, LDA
, INFO
)
3 * -- LAPACK auxiliary routine
(version
3.1) --
4 * Univ
. of Tennessee
, Univ
. of California Berkeley and NAG Ltd
..
7 * .. Scalar Arguments
..
9 INTEGER INFO
, KL
, KU
, LDA
, M
, N
10 DOUBLE PRECISION CFROM
, CTO
12 * .. Array Arguments
..
13 COMPLEX*16 A
( LDA
, * )
19 * ZLASCL multiplies the M by N
complex matrix A by the
real scalar
20 * CTO
/CFROM
. This is done without over
/underflow as long as the final
21 * result CTO*A
(I
,J
)/CFROM does not over
/underflow
. TYPE specifies that
22 * A may be full
, upper triangular
, lower triangular
, upper Hessenberg
,
28 * TYPE
(input
) CHARACTER*1
29 * TYPE indices the storage type of the input matrix
.
30 * = 'G': A is a full matrix
.
31 * = 'L': A is a lower triangular matrix
.
32 * = 'U': A is an upper triangular matrix
.
33 * = 'H': A is an upper Hessenberg matrix
.
34 * = 'B': A is a symmetric band matrix with lower bandwidth KL
35 * and upper bandwidth KU and with the only the lower
37 * = 'Q': A is a symmetric band matrix with lower bandwidth KL
38 * and upper bandwidth KU and with the only the upper
40 * = 'Z': A is a band matrix with lower bandwidth KL and upper
44 * The lower bandwidth of A
. Referenced only
if TYPE
= 'B',
48 * The upper bandwidth of A
. Referenced only
if TYPE
= 'B',
51 * CFROM
(input
) DOUBLE PRECISION
52 * CTO
(input
) DOUBLE PRECISION
53 * The matrix A is multiplied by CTO
/CFROM
. A
(I
,J
) is computed
54 * without over
/underflow
if the final result CTO*A
(I
,J
)/CFROM
55 * can be represented without over
/underflow
. CFROM must be
59 * The number of rows of the matrix A
. M
>= 0.
62 * The number of columns of the matrix A
. N
>= 0.
64 * A
(input
/output
) COMPLEX*16 array
, dimension (LDA
,N
)
65 * The matrix
to be multiplied by CTO
/CFROM
. See TYPE
for the
69 * The leading
dimension of the array A
. LDA
>= max
(1,M
).
71 * INFO
(output
) INTEGER
73 * <0 - if INFO
= -i
, the i
-th argument had an illegal value
.
75 * =====================================================================
78 DOUBLE PRECISION ZERO
, ONE
79 PARAMETER ( ZERO
= 0.0D0
, ONE
= 1.0D0
)
83 INTEGER I
, ITYPE
, J
, K1
, K2
, K3
, K4
84 DOUBLE PRECISION BIGNUM
, CFROM1
, CFROMC
, CTO1
, CTOC
, MUL
, SMLNUM
86 * .. External Functions
..
88 DOUBLE PRECISION DLAMCH
89 EXTERNAL LSAME
, DLAMCH
91 * .. Intrinsic Functions
..
92 INTRINSIC ABS
, MAX
, MIN
94 * .. External Subroutines
..
97 * .. Executable Statements
..
99 * Test the input arguments
103 IF( LSAME
( TYPE
, 'G' ) ) THEN
105 ELSE IF( LSAME
( TYPE
, 'L' ) ) THEN
107 ELSE IF( LSAME
( TYPE
, 'U' ) ) THEN
109 ELSE IF( LSAME
( TYPE
, 'H' ) ) THEN
111 ELSE IF( LSAME
( TYPE
, 'B' ) ) THEN
113 ELSE IF( LSAME
( TYPE
, 'Q' ) ) THEN
115 ELSE IF( LSAME
( TYPE
, 'Z' ) ) THEN
121 IF( ITYPE
.EQ
.-1 ) THEN
123 ELSE IF( CFROM
.EQ
.ZERO
) THEN
125 ELSE IF( M
.LT
.0 ) THEN
127 ELSE IF( N
.LT
.0 .OR
. ( ITYPE
.EQ
.4 .AND
. N
.NE
.M
) .OR
.
128 $
( ITYPE
.EQ
.5 .AND
. N
.NE
.M
) ) THEN
130 ELSE IF( ITYPE
.LE
.3 .AND
. LDA
.LT
.MAX
( 1, M
) ) THEN
132 ELSE IF( ITYPE
.GE
.4 ) THEN
133 IF( KL
.LT
.0 .OR
. KL
.GT
.MAX
( M
-1, 0 ) ) THEN
135 ELSE IF( KU
.LT
.0 .OR
. KU
.GT
.MAX
( N
-1, 0 ) .OR
.
136 $
( ( ITYPE
.EQ
.4 .OR
. ITYPE
.EQ
.5 ) .AND
. KL
.NE
.KU
) )
139 ELSE IF( ( ITYPE
.EQ
.4 .AND
. LDA
.LT
.KL
+1 ) .OR
.
140 $
( ITYPE
.EQ
.5 .AND
. LDA
.LT
.KU
+1 ) .OR
.
141 $
( ITYPE
.EQ
.6 .AND
. LDA
.LT
.2*KL
+KU
+1 ) ) THEN
147 CALL XERBLA
( 'ZLASCL', -INFO
)
151 * Quick
return if possible
153 IF( N
.EQ
.0 .OR
. M
.EQ
.0 )
156 * Get machine parameters
158 SMLNUM
= DLAMCH
( 'S' )
159 BIGNUM
= ONE
/ SMLNUM
165 CFROM1
= CFROMC*SMLNUM
167 IF( ABS
( CFROM1
).GT
.ABS
( CTOC
) .AND
. CTOC
.NE
.ZERO
) THEN
171 ELSE IF( ABS
( CTO1
).GT
.ABS
( CFROMC
) ) THEN
180 IF( ITYPE
.EQ
.0 ) THEN
186 A
( I
, J
) = A
( I
, J
)*MUL
190 ELSE IF( ITYPE
.EQ
.1 ) THEN
192 * Lower triangular matrix
196 A
( I
, J
) = A
( I
, J
)*MUL
200 ELSE IF( ITYPE
.EQ
.2 ) THEN
202 * Upper triangular matrix
205 DO 60 I
= 1, MIN
( J
, M
)
206 A
( I
, J
) = A
( I
, J
)*MUL
210 ELSE IF( ITYPE
.EQ
.3 ) THEN
212 * Upper Hessenberg matrix
215 DO 80 I
= 1, MIN
( J
+1, M
)
216 A
( I
, J
) = A
( I
, J
)*MUL
220 ELSE IF( ITYPE
.EQ
.4 ) THEN
222 * Lower half of a symmetric band matrix
227 DO 100 I
= 1, MIN
( K3
, K4
-J
)
228 A
( I
, J
) = A
( I
, J
)*MUL
232 ELSE IF( ITYPE
.EQ
.5 ) THEN
234 * Upper half of a symmetric band matrix
239 DO 120 I
= MAX
( K1
-J
, 1 ), K3
240 A
( I
, J
) = A
( I
, J
)*MUL
244 ELSE IF( ITYPE
.EQ
.6 ) THEN
253 DO 140 I
= MAX
( K1
-J
, K2
), MIN
( K3
, K4
-J
)
254 A
( I
, J
) = A
( I
, J
)*MUL