LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
slascl.f
Go to the documentation of this file.
00001 *> \brief \b SLASCL
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *> \htmlonly
00009 *> Download SLASCL + dependencies 
00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slascl.f"> 
00011 *> [TGZ]</a> 
00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slascl.f"> 
00013 *> [ZIP]</a> 
00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slascl.f"> 
00015 *> [TXT]</a>
00016 *> \endhtmlonly 
00017 *
00018 *  Definition:
00019 *  ===========
00020 *
00021 *       SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
00022 * 
00023 *       .. Scalar Arguments ..
00024 *       CHARACTER          TYPE
00025 *       INTEGER            INFO, KL, KU, LDA, M, N
00026 *       REAL               CFROM, CTO
00027 *       ..
00028 *       .. Array Arguments ..
00029 *       REAL               A( LDA, * )
00030 *       ..
00031 *  
00032 *
00033 *> \par Purpose:
00034 *  =============
00035 *>
00036 *> \verbatim
00037 *>
00038 *> SLASCL multiplies the M by N real matrix A by the real scalar
00039 *> CTO/CFROM.  This is done without over/underflow as long as the final
00040 *> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
00041 *> A may be full, upper triangular, lower triangular, upper Hessenberg,
00042 *> or banded.
00043 *> \endverbatim
00044 *
00045 *  Arguments:
00046 *  ==========
00047 *
00048 *> \param[in] TYPE
00049 *> \verbatim
00050 *>          TYPE is CHARACTER*1
00051 *>          TYPE indices the storage type of the input matrix.
00052 *>          = 'G':  A is a full matrix.
00053 *>          = 'L':  A is a lower triangular matrix.
00054 *>          = 'U':  A is an upper triangular matrix.
00055 *>          = 'H':  A is an upper Hessenberg matrix.
00056 *>          = 'B':  A is a symmetric band matrix with lower bandwidth KL
00057 *>                  and upper bandwidth KU and with the only the lower
00058 *>                  half stored.
00059 *>          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
00060 *>                  and upper bandwidth KU and with the only the upper
00061 *>                  half stored.
00062 *>          = 'Z':  A is a band matrix with lower bandwidth KL and upper
00063 *>                  bandwidth KU. See SGBTRF for storage details.
00064 *> \endverbatim
00065 *>
00066 *> \param[in] KL
00067 *> \verbatim
00068 *>          KL is INTEGER
00069 *>          The lower bandwidth of A.  Referenced only if TYPE = 'B',
00070 *>          'Q' or 'Z'.
00071 *> \endverbatim
00072 *>
00073 *> \param[in] KU
00074 *> \verbatim
00075 *>          KU is INTEGER
00076 *>          The upper bandwidth of A.  Referenced only if TYPE = 'B',
00077 *>          'Q' or 'Z'.
00078 *> \endverbatim
00079 *>
00080 *> \param[in] CFROM
00081 *> \verbatim
00082 *>          CFROM is REAL
00083 *> \endverbatim
00084 *>
00085 *> \param[in] CTO
00086 *> \verbatim
00087 *>          CTO is REAL
00088 *>
00089 *>          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
00090 *>          without over/underflow if the final result CTO*A(I,J)/CFROM
00091 *>          can be represented without over/underflow.  CFROM must be
00092 *>          nonzero.
00093 *> \endverbatim
00094 *>
00095 *> \param[in] M
00096 *> \verbatim
00097 *>          M is INTEGER
00098 *>          The number of rows of the matrix A.  M >= 0.
00099 *> \endverbatim
00100 *>
00101 *> \param[in] N
00102 *> \verbatim
00103 *>          N is INTEGER
00104 *>          The number of columns of the matrix A.  N >= 0.
00105 *> \endverbatim
00106 *>
00107 *> \param[in,out] A
00108 *> \verbatim
00109 *>          A is REAL array, dimension (LDA,N)
00110 *>          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
00111 *>          storage type.
00112 *> \endverbatim
00113 *>
00114 *> \param[in] LDA
00115 *> \verbatim
00116 *>          LDA is INTEGER
00117 *>          The leading dimension of the array A.  LDA >= max(1,M).
00118 *> \endverbatim
00119 *>
00120 *> \param[out] INFO
00121 *> \verbatim
00122 *>          INFO is INTEGER
00123 *>          0  - successful exit
00124 *>          <0 - if INFO = -i, the i-th argument had an illegal value.
00125 *> \endverbatim
00126 *
00127 *  Authors:
00128 *  ========
00129 *
00130 *> \author Univ. of Tennessee 
00131 *> \author Univ. of California Berkeley 
00132 *> \author Univ. of Colorado Denver 
00133 *> \author NAG Ltd. 
00134 *
00135 *> \date November 2011
00136 *
00137 *> \ingroup auxOTHERauxiliary
00138 *
00139 *  =====================================================================
00140       SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
00141 *
00142 *  -- LAPACK auxiliary routine (version 3.4.0) --
00143 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00144 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00145 *     November 2011
00146 *
00147 *     .. Scalar Arguments ..
00148       CHARACTER          TYPE
00149       INTEGER            INFO, KL, KU, LDA, M, N
00150       REAL               CFROM, CTO
00151 *     ..
00152 *     .. Array Arguments ..
00153       REAL               A( LDA, * )
00154 *     ..
00155 *
00156 *  =====================================================================
00157 *
00158 *     .. Parameters ..
00159       REAL               ZERO, ONE
00160       PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
00161 *     ..
00162 *     .. Local Scalars ..
00163       LOGICAL            DONE
00164       INTEGER            I, ITYPE, J, K1, K2, K3, K4
00165       REAL               BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
00166 *     ..
00167 *     .. External Functions ..
00168       LOGICAL            LSAME, SISNAN
00169       REAL               SLAMCH
00170       EXTERNAL           LSAME, SLAMCH, SISNAN
00171 *     ..
00172 *     .. Intrinsic Functions ..
00173       INTRINSIC          ABS, MAX, MIN
00174 *     ..
00175 *     .. External Subroutines ..
00176       EXTERNAL           XERBLA
00177 *     ..
00178 *     .. Executable Statements ..
00179 *
00180 *     Test the input arguments
00181 *
00182       INFO = 0
00183 *
00184       IF( LSAME( TYPE, 'G' ) ) THEN
00185          ITYPE = 0
00186       ELSE IF( LSAME( TYPE, 'L' ) ) THEN
00187          ITYPE = 1
00188       ELSE IF( LSAME( TYPE, 'U' ) ) THEN
00189          ITYPE = 2
00190       ELSE IF( LSAME( TYPE, 'H' ) ) THEN
00191          ITYPE = 3
00192       ELSE IF( LSAME( TYPE, 'B' ) ) THEN
00193          ITYPE = 4
00194       ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
00195          ITYPE = 5
00196       ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
00197          ITYPE = 6
00198       ELSE
00199          ITYPE = -1
00200       END IF
00201 *
00202       IF( ITYPE.EQ.-1 ) THEN
00203          INFO = -1
00204       ELSE IF( CFROM.EQ.ZERO .OR. SISNAN(CFROM) ) THEN
00205          INFO = -4
00206       ELSE IF( SISNAN(CTO) ) THEN
00207          INFO = -5
00208       ELSE IF( M.LT.0 ) THEN
00209          INFO = -6
00210       ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
00211      $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
00212          INFO = -7
00213       ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
00214          INFO = -9
00215       ELSE IF( ITYPE.GE.4 ) THEN
00216          IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
00217             INFO = -2
00218          ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
00219      $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
00220      $             THEN
00221             INFO = -3
00222          ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
00223      $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
00224      $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
00225             INFO = -9
00226          END IF
00227       END IF
00228 *
00229       IF( INFO.NE.0 ) THEN
00230          CALL XERBLA( 'SLASCL', -INFO )
00231          RETURN
00232       END IF
00233 *
00234 *     Quick return if possible
00235 *
00236       IF( N.EQ.0 .OR. M.EQ.0 )
00237      $   RETURN
00238 *
00239 *     Get machine parameters
00240 *
00241       SMLNUM = SLAMCH( 'S' )
00242       BIGNUM = ONE / SMLNUM
00243 *
00244       CFROMC = CFROM
00245       CTOC = CTO
00246 *
00247    10 CONTINUE
00248       CFROM1 = CFROMC*SMLNUM
00249       IF( CFROM1.EQ.CFROMC ) THEN
00250 !        CFROMC is an inf.  Multiply by a correctly signed zero for
00251 !        finite CTOC, or a NaN if CTOC is infinite.
00252          MUL = CTOC / CFROMC
00253          DONE = .TRUE.
00254          CTO1 = CTOC
00255       ELSE
00256          CTO1 = CTOC / BIGNUM
00257          IF( CTO1.EQ.CTOC ) THEN
00258 !           CTOC is either 0 or an inf.  In both cases, CTOC itself
00259 !           serves as the correct multiplication factor.
00260             MUL = CTOC
00261             DONE = .TRUE.
00262             CFROMC = ONE
00263          ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
00264             MUL = SMLNUM
00265             DONE = .FALSE.
00266             CFROMC = CFROM1
00267          ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
00268             MUL = BIGNUM
00269             DONE = .FALSE.
00270             CTOC = CTO1
00271          ELSE
00272             MUL = CTOC / CFROMC
00273             DONE = .TRUE.
00274          END IF
00275       END IF
00276 *
00277       IF( ITYPE.EQ.0 ) THEN
00278 *
00279 *        Full matrix
00280 *
00281          DO 30 J = 1, N
00282             DO 20 I = 1, M
00283                A( I, J ) = A( I, J )*MUL
00284    20       CONTINUE
00285    30    CONTINUE
00286 *
00287       ELSE IF( ITYPE.EQ.1 ) THEN
00288 *
00289 *        Lower triangular matrix
00290 *
00291          DO 50 J = 1, N
00292             DO 40 I = J, M
00293                A( I, J ) = A( I, J )*MUL
00294    40       CONTINUE
00295    50    CONTINUE
00296 *
00297       ELSE IF( ITYPE.EQ.2 ) THEN
00298 *
00299 *        Upper triangular matrix
00300 *
00301          DO 70 J = 1, N
00302             DO 60 I = 1, MIN( J, M )
00303                A( I, J ) = A( I, J )*MUL
00304    60       CONTINUE
00305    70    CONTINUE
00306 *
00307       ELSE IF( ITYPE.EQ.3 ) THEN
00308 *
00309 *        Upper Hessenberg matrix
00310 *
00311          DO 90 J = 1, N
00312             DO 80 I = 1, MIN( J+1, M )
00313                A( I, J ) = A( I, J )*MUL
00314    80       CONTINUE
00315    90    CONTINUE
00316 *
00317       ELSE IF( ITYPE.EQ.4 ) THEN
00318 *
00319 *        Lower half of a symmetric band matrix
00320 *
00321          K3 = KL + 1
00322          K4 = N + 1
00323          DO 110 J = 1, N
00324             DO 100 I = 1, MIN( K3, K4-J )
00325                A( I, J ) = A( I, J )*MUL
00326   100       CONTINUE
00327   110    CONTINUE
00328 *
00329       ELSE IF( ITYPE.EQ.5 ) THEN
00330 *
00331 *        Upper half of a symmetric band matrix
00332 *
00333          K1 = KU + 2
00334          K3 = KU + 1
00335          DO 130 J = 1, N
00336             DO 120 I = MAX( K1-J, 1 ), K3
00337                A( I, J ) = A( I, J )*MUL
00338   120       CONTINUE
00339   130    CONTINUE
00340 *
00341       ELSE IF( ITYPE.EQ.6 ) THEN
00342 *
00343 *        Band matrix
00344 *
00345          K1 = KL + KU + 2
00346          K2 = KL + 1
00347          K3 = 2*KL + KU + 1
00348          K4 = KL + KU + 1 + M
00349          DO 150 J = 1, N
00350             DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
00351                A( I, J ) = A( I, J )*MUL
00352   140       CONTINUE
00353   150    CONTINUE
00354 *
00355       END IF
00356 *
00357       IF( .NOT.DONE )
00358      $   GO TO 10
00359 *
00360       RETURN
00361 *
00362 *     End of SLASCL
00363 *
00364       END
 All Files Functions