clascl.f

          SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
    *
    *  -- LAPACK auxiliary routine (version 3.1) --
    *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
    *     November 2006
    *
    *     .. Scalar Arguments ..
          CHARACTER          TYPE
          INTEGER            INFO, KL, KU, LDA, M, N
          REAL               CFROM, CTO
    *     ..
    *     .. Array Arguments ..
          COMPLEX            A( LDA, * )
    *     ..
    *
    *  Purpose
    *  =======
    *
    *  CLASCL multiplies the M by N complex 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.
    *
    *  Arguments
    *  =========
    *
    *  TYPE    (input) 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.
    *
    *  KL      (input) INTEGER
    *          The lower bandwidth of A.  Referenced only if TYPE = 'B',
    *          'Q' or 'Z'.
    *
    *  KU      (input) INTEGER
    *          The upper bandwidth of A.  Referenced only if TYPE = 'B',
    *          'Q' or 'Z'.
    *
    *  CFROM   (input) REAL
    *  CTO     (input) REAL
    *          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.
    *
    *  M       (input) INTEGER
    *          The number of rows of the matrix A.  M >= 0.
    *
    *  N       (input) INTEGER
    *          The number of columns of the matrix A.  N >= 0.
    *
    *  A       (input/output) COMPLEX array, dimension (LDA,N)
    *          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
    *          storage type.
    *
    *  LDA     (input) INTEGER
    *          The leading dimension of the array A.  LDA >= max(1,M).
    *
    *  INFO    (output) INTEGER
    *          0  - successful exit
    *          <0 - if INFO = -i, the i-th argument had an illegal value.
    *
    *  =====================================================================
    *
    *     .. Parameters ..
          REAL               ZERO, ONE
          PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
    *     ..
    *     .. Local Scalars ..
          LOGICAL            DONE
          INTEGER            I, ITYPE, J, K1, K2, K3, K4
          REAL               BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
    *     ..
    *     .. External Functions ..
          LOGICAL            LSAME
          REAL               SLAMCH
          EXTERNAL           LSAME, SLAMCH
    *     ..
    *     .. 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 ) THEN
             INFO = -4
          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( 'CLASCL', -INFO )
             RETURN
          END IF
    *
    *     Quick return if possible
    *
          IF( N.EQ.0 .OR. M.EQ.0 )
         $   RETURN
    *
    *     Get machine parameters
    *
          SMLNUM = SLAMCH( 'S' )
          BIGNUM = ONE / SMLNUM
    *
          CFROMC = CFROM
          CTOC = CTO
    *
       10 CONTINUE
          CFROM1 = CFROMC*SMLNUM
          CTO1 = CTOC / BIGNUM
          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
    *
          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 CLASCL
    *
          END