exciting-0.9.218
[exciting.git] / src / LAPACK / zlascl.f
blob36bb24450a9b52315d8dfc981be72468eea658b7
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..
5 * November 2006
7 * .. Scalar Arguments ..
8 CHARACTER TYPE
9 INTEGER INFO, KL, KU, LDA, M, N
10 DOUBLE PRECISION CFROM, CTO
11 * ..
12 * .. Array Arguments ..
13 COMPLEX*16 A( LDA, * )
14 * ..
16 * Purpose
17 * =======
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,
23 * or banded.
25 * Arguments
26 * =========
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
36 * half stored.
37 * = 'Q': A is a symmetric band matrix with lower bandwidth KL
38 * and upper bandwidth KU and with the only the upper
39 * half stored.
40 * = 'Z': A is a band matrix with lower bandwidth KL and upper
41 * bandwidth KU.
43 * KL (input) INTEGER
44 * The lower bandwidth of A. Referenced only if TYPE = 'B',
45 * 'Q' or 'Z'.
47 * KU (input) INTEGER
48 * The upper bandwidth of A. Referenced only if TYPE = 'B',
49 * 'Q' or 'Z'.
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
56 * nonzero.
58 * M (input) INTEGER
59 * The number of rows of the matrix A. M >= 0.
61 * N (input) INTEGER
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
66 * storage type.
68 * LDA (input) INTEGER
69 * The leading dimension of the array A. LDA >= max(1,M).
71 * INFO (output) INTEGER
72 * 0 - successful exit
73 * <0 - if INFO = -i, the i-th argument had an illegal value.
75 * =====================================================================
77 * .. Parameters ..
78 DOUBLE PRECISION ZERO, ONE
79 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
80 * ..
81 * .. Local Scalars ..
82 LOGICAL DONE
83 INTEGER I, ITYPE, J, K1, K2, K3, K4
84 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
85 * ..
86 * .. External Functions ..
87 LOGICAL LSAME
88 DOUBLE PRECISION DLAMCH
89 EXTERNAL LSAME, DLAMCH
90 * ..
91 * .. Intrinsic Functions ..
92 INTRINSIC ABS, MAX, MIN
93 * ..
94 * .. External Subroutines ..
95 EXTERNAL XERBLA
96 * ..
97 * .. Executable Statements ..
99 * Test the input arguments
101 INFO = 0
103 IF( LSAME( TYPE, 'G' ) ) THEN
104 ITYPE = 0
105 ELSE IF( LSAME( TYPE, 'L' ) ) THEN
106 ITYPE = 1
107 ELSE IF( LSAME( TYPE, 'U' ) ) THEN
108 ITYPE = 2
109 ELSE IF( LSAME( TYPE, 'H' ) ) THEN
110 ITYPE = 3
111 ELSE IF( LSAME( TYPE, 'B' ) ) THEN
112 ITYPE = 4
113 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
114 ITYPE = 5
115 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
116 ITYPE = 6
117 ELSE
118 ITYPE = -1
119 END IF
121 IF( ITYPE.EQ.-1 ) THEN
122 INFO = -1
123 ELSE IF( CFROM.EQ.ZERO ) THEN
124 INFO = -4
125 ELSE IF( M.LT.0 ) THEN
126 INFO = -6
127 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
128 $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
129 INFO = -7
130 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
131 INFO = -9
132 ELSE IF( ITYPE.GE.4 ) THEN
133 IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
134 INFO = -2
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 ) )
137 $ THEN
138 INFO = -3
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
142 INFO = -9
143 END IF
144 END IF
146 IF( INFO.NE.0 ) THEN
147 CALL XERBLA( 'ZLASCL', -INFO )
148 RETURN
149 END IF
151 * Quick return if possible
153 IF( N.EQ.0 .OR. M.EQ.0 )
154 $ RETURN
156 * Get machine parameters
158 SMLNUM = DLAMCH( 'S' )
159 BIGNUM = ONE / SMLNUM
161 CFROMC = CFROM
162 CTOC = CTO
164 10 CONTINUE
165 CFROM1 = CFROMC*SMLNUM
166 CTO1 = CTOC / BIGNUM
167 IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
168 MUL = SMLNUM
169 DONE = .FALSE.
170 CFROMC = CFROM1
171 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
172 MUL = BIGNUM
173 DONE = .FALSE.
174 CTOC = CTO1
175 ELSE
176 MUL = CTOC / CFROMC
177 DONE = .TRUE.
178 END IF
180 IF( ITYPE.EQ.0 ) THEN
182 * Full matrix
184 DO 30 J = 1, N
185 DO 20 I = 1, M
186 A( I, J ) = A( I, J )*MUL
187 20 CONTINUE
188 30 CONTINUE
190 ELSE IF( ITYPE.EQ.1 ) THEN
192 * Lower triangular matrix
194 DO 50 J = 1, N
195 DO 40 I = J, M
196 A( I, J ) = A( I, J )*MUL
197 40 CONTINUE
198 50 CONTINUE
200 ELSE IF( ITYPE.EQ.2 ) THEN
202 * Upper triangular matrix
204 DO 70 J = 1, N
205 DO 60 I = 1, MIN( J, M )
206 A( I, J ) = A( I, J )*MUL
207 60 CONTINUE
208 70 CONTINUE
210 ELSE IF( ITYPE.EQ.3 ) THEN
212 * Upper Hessenberg matrix
214 DO 90 J = 1, N
215 DO 80 I = 1, MIN( J+1, M )
216 A( I, J ) = A( I, J )*MUL
217 80 CONTINUE
218 90 CONTINUE
220 ELSE IF( ITYPE.EQ.4 ) THEN
222 * Lower half of a symmetric band matrix
224 K3 = KL + 1
225 K4 = N + 1
226 DO 110 J = 1, N
227 DO 100 I = 1, MIN( K3, K4-J )
228 A( I, J ) = A( I, J )*MUL
229 100 CONTINUE
230 110 CONTINUE
232 ELSE IF( ITYPE.EQ.5 ) THEN
234 * Upper half of a symmetric band matrix
236 K1 = KU + 2
237 K3 = KU + 1
238 DO 130 J = 1, N
239 DO 120 I = MAX( K1-J, 1 ), K3
240 A( I, J ) = A( I, J )*MUL
241 120 CONTINUE
242 130 CONTINUE
244 ELSE IF( ITYPE.EQ.6 ) THEN
246 * Band matrix
248 K1 = KL + KU + 2
249 K2 = KL + 1
250 K3 = 2*KL + KU + 1
251 K4 = KL + KU + 1 + M
252 DO 150 J = 1, N
253 DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
254 A( I, J ) = A( I, J )*MUL
255 140 CONTINUE
256 150 CONTINUE
258 END IF
260 IF( .NOT.DONE )
261 $ GO TO 10
263 RETURN
265 * End of ZLASCL