--- /dev/null
+*> \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
OSDN Git Service
