| *> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. |
| * |
| * =========== DOCUMENTATION =========== |
| * |
| * Online html documentation available at |
| * http://www.netlib.org/lapack/explore-html/ |
| * |
| *> \htmlonly |
| *> Download DLASCL + dependencies |
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlascl.f"> |
| *> [TGZ]</a> |
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlascl.f"> |
| *> [ZIP]</a> |
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlascl.f"> |
| *> [TXT]</a> |
| *> \endhtmlonly |
| * |
| * Definition: |
| * =========== |
| * |
| * SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) |
| * |
| * .. Scalar Arguments .. |
| * CHARACTER TYPE |
| * INTEGER INFO, KL, KU, LDA, M, N |
| * DOUBLE PRECISION CFROM, CTO |
| * .. |
| * .. Array Arguments .. |
| * DOUBLE PRECISION A( LDA, * ) |
| * .. |
| * |
| * |
| *> \par Purpose: |
| * ============= |
| *> |
| *> \verbatim |
| *> |
| *> DLASCL multiplies the M by N real matrix A by the real scalar |
| *> CTO/CFROM. This is done without over/underflow as long as the final |
| *> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that |
| *> A may be full, upper triangular, lower triangular, upper Hessenberg, |
| *> or banded. |
| *> \endverbatim |
| * |
| * Arguments: |
| * ========== |
| * |
| *> \param[in] TYPE |
| *> \verbatim |
| *> TYPE is CHARACTER*1 |
| *> TYPE indices the storage type of the input matrix. |
| *> = 'G': A is a full matrix. |
| *> = 'L': A is a lower triangular matrix. |
| *> = 'U': A is an upper triangular matrix. |
| *> = 'H': A is an upper Hessenberg matrix. |
| *> = 'B': A is a symmetric band matrix with lower bandwidth KL |
| *> and upper bandwidth KU and with the only the lower |
| *> half stored. |
| *> = 'Q': A is a symmetric band matrix with lower bandwidth KL |
| *> and upper bandwidth KU and with the only the upper |
| *> half stored. |
| *> = 'Z': A is a band matrix with lower bandwidth KL and upper |
| *> bandwidth KU. See DGBTRF for storage details. |
| *> \endverbatim |
| *> |
| *> \param[in] KL |
| *> \verbatim |
| *> KL is INTEGER |
| *> The lower bandwidth of A. Referenced only if TYPE = 'B', |
| *> 'Q' or 'Z'. |
| *> \endverbatim |
| *> |
| *> \param[in] KU |
| *> \verbatim |
| *> KU is INTEGER |
| *> The upper bandwidth of A. Referenced only if TYPE = 'B', |
| *> 'Q' or 'Z'. |
| *> \endverbatim |
| *> |
| *> \param[in] CFROM |
| *> \verbatim |
| *> CFROM is DOUBLE PRECISION |
| *> \endverbatim |
| *> |
| *> \param[in] CTO |
| *> \verbatim |
| *> CTO is DOUBLE PRECISION |
| *> |
| *> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed |
| *> without over/underflow if the final result CTO*A(I,J)/CFROM |
| *> can be represented without over/underflow. CFROM must be |
| *> nonzero. |
| *> \endverbatim |
| *> |
| *> \param[in] M |
| *> \verbatim |
| *> M is INTEGER |
| *> The number of rows of the matrix A. M >= 0. |
| *> \endverbatim |
| *> |
| *> \param[in] N |
| *> \verbatim |
| *> N is INTEGER |
| *> The number of columns of the matrix A. N >= 0. |
| *> \endverbatim |
| *> |
| *> \param[in,out] A |
| *> \verbatim |
| *> A is DOUBLE PRECISION array, dimension (LDA,N) |
| *> The matrix to be multiplied by CTO/CFROM. See TYPE for the |
| *> storage type. |
| *> \endverbatim |
| *> |
| *> \param[in] LDA |
| *> \verbatim |
| *> LDA is INTEGER |
| *> The leading dimension of the array A. LDA >= max(1,M). |
| *> \endverbatim |
| *> |
| *> \param[out] INFO |
| *> \verbatim |
| *> INFO is INTEGER |
| *> 0 - successful exit |
| *> <0 - if INFO = -i, the i-th argument had an illegal value. |
| *> \endverbatim |
| * |
| * Authors: |
| * ======== |
| * |
| *> \author Univ. of Tennessee |
| *> \author Univ. of California Berkeley |
| *> \author Univ. of Colorado Denver |
| *> \author NAG Ltd. |
| * |
| *> \date September 2012 |
| * |
| *> \ingroup auxOTHERauxiliary |
| * |
| * ===================================================================== |
| SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) |
| * |
| * -- LAPACK auxiliary routine (version 3.4.2) -- |
| * -- LAPACK is a software package provided by Univ. of Tennessee, -- |
| * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
| * September 2012 |
| * |
| * .. Scalar Arguments .. |
| CHARACTER TYPE |
| INTEGER INFO, KL, KU, LDA, M, N |
| DOUBLE PRECISION CFROM, CTO |
| * .. |
| * .. Array Arguments .. |
| DOUBLE PRECISION A( LDA, * ) |
| * .. |
| * |
| * ===================================================================== |
| * |
| * .. Parameters .. |
| DOUBLE PRECISION ZERO, ONE |
| PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) |
| * .. |
| * .. Local Scalars .. |
| LOGICAL DONE |
| INTEGER I, ITYPE, J, K1, K2, K3, K4 |
| DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM |
| * .. |
| * .. External Functions .. |
| LOGICAL LSAME, DISNAN |
| DOUBLE PRECISION DLAMCH |
| EXTERNAL LSAME, DLAMCH, DISNAN |
| * .. |
| * .. Intrinsic Functions .. |
| INTRINSIC ABS, MAX, MIN |
| * .. |
| * .. External Subroutines .. |
| EXTERNAL XERBLA |
| * .. |
| * .. Executable Statements .. |
| * |
| * Test the input arguments |
| * |
| INFO = 0 |
| * |
| IF( LSAME( TYPE, 'G' ) ) THEN |
| ITYPE = 0 |
| ELSE IF( LSAME( TYPE, 'L' ) ) THEN |
| ITYPE = 1 |
| ELSE IF( LSAME( TYPE, 'U' ) ) THEN |
| ITYPE = 2 |
| ELSE IF( LSAME( TYPE, 'H' ) ) THEN |
| ITYPE = 3 |
| ELSE IF( LSAME( TYPE, 'B' ) ) THEN |
| ITYPE = 4 |
| ELSE IF( LSAME( TYPE, 'Q' ) ) THEN |
| ITYPE = 5 |
| ELSE IF( LSAME( TYPE, 'Z' ) ) THEN |
| ITYPE = 6 |
| ELSE |
| ITYPE = -1 |
| END IF |
| * |
| IF( ITYPE.EQ.-1 ) THEN |
| INFO = -1 |
| ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN |
| INFO = -4 |
| ELSE IF( DISNAN(CTO) ) THEN |
| INFO = -5 |
| ELSE IF( M.LT.0 ) THEN |
| INFO = -6 |
| ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. |
| $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN |
| INFO = -7 |
| ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN |
| INFO = -9 |
| ELSE IF( ITYPE.GE.4 ) THEN |
| IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN |
| INFO = -2 |
| ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. |
| $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) |
| $ THEN |
| INFO = -3 |
| ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. |
| $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. |
| $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN |
| INFO = -9 |
| END IF |
| END IF |
| * |
| IF( INFO.NE.0 ) THEN |
| CALL XERBLA( 'DLASCL', -INFO ) |
| RETURN |
| END IF |
| * |
| * Quick return if possible |
| * |
| IF( N.EQ.0 .OR. M.EQ.0 ) |
| $ RETURN |
| * |
| * Get machine parameters |
| * |
| SMLNUM = DLAMCH( 'S' ) |
| BIGNUM = ONE / SMLNUM |
| * |
| CFROMC = CFROM |
| CTOC = CTO |
| * |
| 10 CONTINUE |
| CFROM1 = CFROMC*SMLNUM |
| IF( CFROM1.EQ.CFROMC ) THEN |
| ! CFROMC is an inf. Multiply by a correctly signed zero for |
| ! finite CTOC, or a NaN if CTOC is infinite. |
| MUL = CTOC / CFROMC |
| DONE = .TRUE. |
| CTO1 = CTOC |
| ELSE |
| CTO1 = CTOC / BIGNUM |
| IF( CTO1.EQ.CTOC ) THEN |
| ! CTOC is either 0 or an inf. In both cases, CTOC itself |
| ! serves as the correct multiplication factor. |
| MUL = CTOC |
| DONE = .TRUE. |
| CFROMC = ONE |
| ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN |
| MUL = SMLNUM |
| DONE = .FALSE. |
| CFROMC = CFROM1 |
| ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN |
| MUL = BIGNUM |
| DONE = .FALSE. |
| CTOC = CTO1 |
| ELSE |
| MUL = CTOC / CFROMC |
| DONE = .TRUE. |
| END IF |
| END IF |
| * |
| IF( ITYPE.EQ.0 ) THEN |
| * |
| * Full matrix |
| * |
| DO 30 J = 1, N |
| DO 20 I = 1, M |
| A( I, J ) = A( I, J )*MUL |
| 20 CONTINUE |
| 30 CONTINUE |
| * |
| ELSE IF( ITYPE.EQ.1 ) THEN |
| * |
| * Lower triangular matrix |
| * |
| DO 50 J = 1, N |
| DO 40 I = J, M |
| A( I, J ) = A( I, J )*MUL |
| 40 CONTINUE |
| 50 CONTINUE |
| * |
| ELSE IF( ITYPE.EQ.2 ) THEN |
| * |
| * Upper triangular matrix |
| * |
| DO 70 J = 1, N |
| DO 60 I = 1, MIN( J, M ) |
| A( I, J ) = A( I, J )*MUL |
| 60 CONTINUE |
| 70 CONTINUE |
| * |
| ELSE IF( ITYPE.EQ.3 ) THEN |
| * |
| * Upper Hessenberg matrix |
| * |
| DO 90 J = 1, N |
| DO 80 I = 1, MIN( J+1, M ) |
| A( I, J ) = A( I, J )*MUL |
| 80 CONTINUE |
| 90 CONTINUE |
| * |
| ELSE IF( ITYPE.EQ.4 ) THEN |
| * |
| * Lower half of a symmetric band matrix |
| * |
| K3 = KL + 1 |
| K4 = N + 1 |
| DO 110 J = 1, N |
| DO 100 I = 1, MIN( K3, K4-J ) |
| A( I, J ) = A( I, J )*MUL |
| 100 CONTINUE |
| 110 CONTINUE |
| * |
| ELSE IF( ITYPE.EQ.5 ) THEN |
| * |
| * Upper half of a symmetric band matrix |
| * |
| K1 = KU + 2 |
| K3 = KU + 1 |
| DO 130 J = 1, N |
| DO 120 I = MAX( K1-J, 1 ), K3 |
| A( I, J ) = A( I, J )*MUL |
| 120 CONTINUE |
| 130 CONTINUE |
| * |
| ELSE IF( ITYPE.EQ.6 ) THEN |
| * |
| * Band matrix |
| * |
| K1 = KL + KU + 2 |
| K2 = KL + 1 |
| K3 = 2*KL + KU + 1 |
| K4 = KL + KU + 1 + M |
| DO 150 J = 1, N |
| DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) |
| A( I, J ) = A( I, J )*MUL |
| 140 CONTINUE |
| 150 CONTINUE |
| * |
| END IF |
| * |
| IF( .NOT.DONE ) |
| $ GO TO 10 |
| * |
| RETURN |
| * |
| * End of DLASCL |
| * |
| END |