Annotation of rpl/lapack/lapack/zlascl.f, revision 1.9
1.9 ! bertrand 1: *> \brief \b ZLASCL
! 2: *
! 3: * =========== DOCUMENTATION ===========
! 4: *
! 5: * Online html documentation available at
! 6: * http://www.netlib.org/lapack/explore-html/
! 7: *
! 8: *> \htmlonly
! 9: *> Download ZLASCL + dependencies
! 10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlascl.f">
! 11: *> [TGZ]</a>
! 12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlascl.f">
! 13: *> [ZIP]</a>
! 14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlascl.f">
! 15: *> [TXT]</a>
! 16: *> \endhtmlonly
! 17: *
! 18: * Definition:
! 19: * ===========
! 20: *
! 21: * SUBROUTINE ZLASCL( 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: * COMPLEX*16 A( LDA, * )
! 30: * ..
! 31: *
! 32: *
! 33: *> \par Purpose:
! 34: * =============
! 35: *>
! 36: *> \verbatim
! 37: *>
! 38: *> ZLASCL 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 ZGBTRF 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 COMPLEX*16 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 November 2011
! 136: *
! 137: *> \ingroup complex16OTHERauxiliary
! 138: *
! 139: * =====================================================================
1.1 bertrand 140: SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
141: *
1.9 ! bertrand 142: * -- LAPACK auxiliary routine (version 3.4.0) --
1.1 bertrand 143: * -- LAPACK is a software package provided by Univ. of Tennessee, --
144: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1.9 ! bertrand 145: * November 2011
1.1 bertrand 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: COMPLEX*16 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( 'ZLASCL', -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 ZLASCL
363: *
364: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zlascl.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack