LAPACK: SRC/slascl.f Source File

Go to the documentation of this file.
00001       SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
00002 *
00003 *  -- LAPACK auxiliary routine (version 3.3.0) --
00004 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00005 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00006 *     November 2010
00007 *
00008 *     .. Scalar Arguments ..
00009       CHARACTER          TYPE
00010       INTEGER            INFO, KL, KU, LDA, M, N
00011       REAL               CFROM, CTO
00012 *     ..
00013 *     .. Array Arguments ..
00014       REAL               A( LDA, * )
00015 *     ..
00016 *
00017 *  Purpose
00018 *  =======
00019 *
00020 *  SLASCL multiplies the M by N real matrix A by the real scalar
00021 *  CTO/CFROM.  This is done without over/underflow as long as the final
00022 *  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
00023 *  A may be full, upper triangular, lower triangular, upper Hessenberg,
00024 *  or banded.
00025 *
00026 *  Arguments
00027 *  =========
00028 *
00029 *  TYPE    (input) CHARACTER*1
00030 *          TYPE indices the storage type of the input matrix.
00031 *          = 'G':  A is a full matrix.
00032 *          = 'L':  A is a lower triangular matrix.
00033 *          = 'U':  A is an upper triangular matrix.
00034 *          = 'H':  A is an upper Hessenberg matrix.
00035 *          = 'B':  A is a symmetric band matrix with lower bandwidth KL
00036 *                  and upper bandwidth KU and with the only the lower
00037 *                  half stored.
00038 *          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
00039 *                  and upper bandwidth KU and with the only the upper
00040 *                  half stored.
00041 *          = 'Z':  A is a band matrix with lower bandwidth KL and upper
00042 *                  bandwidth KU. See SGBTRF for storage details.
00043 *
00044 *  KL      (input) INTEGER
00045 *          The lower bandwidth of A.  Referenced only if TYPE = 'B',
00046 *          'Q' or 'Z'.
00047 *
00048 *  KU      (input) INTEGER
00049 *          The upper bandwidth of A.  Referenced only if TYPE = 'B',
00050 *          'Q' or 'Z'.
00051 *
00052 *  CFROM   (input) REAL
00053 *  CTO     (input) REAL
00054 *          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
00055 *          without over/underflow if the final result CTO*A(I,J)/CFROM
00056 *          can be represented without over/underflow.  CFROM must be
00057 *          nonzero.
00058 *
00059 *  M       (input) INTEGER
00060 *          The number of rows of the matrix A.  M >= 0.
00061 *
00062 *  N       (input) INTEGER
00063 *          The number of columns of the matrix A.  N >= 0.
00064 *
00065 *  A       (input/output) REAL array, dimension (LDA,N)
00066 *          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
00067 *          storage type.
00068 *
00069 *  LDA     (input) INTEGER
00070 *          The leading dimension of the array A.  LDA >= max(1,M).
00071 *
00072 *  INFO    (output) INTEGER
00073 *          0  - successful exit
00074 *          <0 - if INFO = -i, the i-th argument had an illegal value.
00075 *
00076 *  =====================================================================
00077 *
00078 *     .. Parameters ..
00079       REAL               ZERO, ONE
00080       PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
00081 *     ..
00082 *     .. Local Scalars ..
00083       LOGICAL            DONE
00084       INTEGER            I, ITYPE, J, K1, K2, K3, K4
00085       REAL               BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
00086 *     ..
00087 *     .. External Functions ..
00088       LOGICAL            LSAME, SISNAN
00089       REAL               SLAMCH
00090       EXTERNAL           LSAME, SLAMCH, SISNAN
00091 *     ..
00092 *     .. Intrinsic Functions ..
00093       INTRINSIC          ABS, MAX, MIN
00094 *     ..
00095 *     .. External Subroutines ..
00096       EXTERNAL           XERBLA
00097 *     ..
00098 *     .. Executable Statements ..
00099 *
00100 *     Test the input arguments
00101 *
00102       INFO = 0
00103 *
00104       IF( LSAME( TYPE, 'G' ) ) THEN
00105          ITYPE = 0
00106       ELSE IF( LSAME( TYPE, 'L' ) ) THEN
00107          ITYPE = 1
00108       ELSE IF( LSAME( TYPE, 'U' ) ) THEN
00109          ITYPE = 2
00110       ELSE IF( LSAME( TYPE, 'H' ) ) THEN
00111          ITYPE = 3
00112       ELSE IF( LSAME( TYPE, 'B' ) ) THEN
00113          ITYPE = 4
00114       ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
00115          ITYPE = 5
00116       ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
00117          ITYPE = 6
00118       ELSE
00119          ITYPE = -1
00120       END IF
00121 *
00122       IF( ITYPE.EQ.-1 ) THEN
00123          INFO = -1
00124       ELSE IF( CFROM.EQ.ZERO .OR. SISNAN(CFROM) ) THEN
00125          INFO = -4
00126       ELSE IF( SISNAN(CTO) ) THEN
00127          INFO = -5
00128       ELSE IF( M.LT.0 ) THEN
00129          INFO = -6
00130       ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
00131      $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
00132          INFO = -7
00133       ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
00134          INFO = -9
00135       ELSE IF( ITYPE.GE.4 ) THEN
00136          IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
00137             INFO = -2
00138          ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
00139      $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
00140      $             THEN
00141             INFO = -3
00142          ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
00143      $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
00144      $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
00145             INFO = -9
00146          END IF
00147       END IF
00148 *
00149       IF( INFO.NE.0 ) THEN
00150          CALL XERBLA( 'SLASCL', -INFO )
00151          RETURN
00152       END IF
00153 *
00154 *     Quick return if possible
00155 *
00156       IF( N.EQ.0 .OR. M.EQ.0 )
00157      $   RETURN
00158 *
00159 *     Get machine parameters
00160 *
00161       SMLNUM = SLAMCH( 'S' )
00162       BIGNUM = ONE / SMLNUM
00163 *
00164       CFROMC = CFROM
00165       CTOC = CTO
00166 *
00167    10 CONTINUE
00168       CFROM1 = CFROMC*SMLNUM
00169       IF( CFROM1.EQ.CFROMC ) THEN
00170 !        CFROMC is an inf.  Multiply by a correctly signed zero for
00171 !        finite CTOC, or a NaN if CTOC is infinite.
00172          MUL = CTOC / CFROMC
00173          DONE = .TRUE.
00174          CTO1 = CTOC
00175       ELSE
00176          CTO1 = CTOC / BIGNUM
00177          IF( CTO1.EQ.CTOC ) THEN
00178 !           CTOC is either 0 or an inf.  In both cases, CTOC itself
00179 !           serves as the correct multiplication factor.
00180             MUL = CTOC
00181             DONE = .TRUE.
00182             CFROMC = ONE
00183          ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
00184             MUL = SMLNUM
00185             DONE = .FALSE.
00186             CFROMC = CFROM1
00187          ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
00188             MUL = BIGNUM
00189             DONE = .FALSE.
00190             CTOC = CTO1
00191          ELSE
00192             MUL = CTOC / CFROMC
00193             DONE = .TRUE.
00194          END IF
00195       END IF
00196 *
00197       IF( ITYPE.EQ.0 ) THEN
00198 *
00199 *        Full matrix
00200 *
00201          DO 30 J = 1, N
00202             DO 20 I = 1, M
00203                A( I, J ) = A( I, J )*MUL
00204    20       CONTINUE
00205    30    CONTINUE
00206 *
00207       ELSE IF( ITYPE.EQ.1 ) THEN
00208 *
00209 *        Lower triangular matrix
00210 *
00211          DO 50 J = 1, N
00212             DO 40 I = J, M
00213                A( I, J ) = A( I, J )*MUL
00214    40       CONTINUE
00215    50    CONTINUE
00216 *
00217       ELSE IF( ITYPE.EQ.2 ) THEN
00218 *
00219 *        Upper triangular matrix
00220 *
00221          DO 70 J = 1, N
00222             DO 60 I = 1, MIN( J, M )
00223                A( I, J ) = A( I, J )*MUL
00224    60       CONTINUE
00225    70    CONTINUE
00226 *
00227       ELSE IF( ITYPE.EQ.3 ) THEN
00228 *
00229 *        Upper Hessenberg matrix
00230 *
00231          DO 90 J = 1, N
00232             DO 80 I = 1, MIN( J+1, M )
00233                A( I, J ) = A( I, J )*MUL
00234    80       CONTINUE
00235    90    CONTINUE
00236 *
00237       ELSE IF( ITYPE.EQ.4 ) THEN
00238 *
00239 *        Lower half of a symmetric band matrix
00240 *
00241          K3 = KL + 1
00242          K4 = N + 1
00243          DO 110 J = 1, N
00244             DO 100 I = 1, MIN( K3, K4-J )
00245                A( I, J ) = A( I, J )*MUL
00246   100       CONTINUE
00247   110    CONTINUE
00248 *
00249       ELSE IF( ITYPE.EQ.5 ) THEN
00250 *
00251 *        Upper half of a symmetric band matrix
00252 *
00253          K1 = KU + 2
00254          K3 = KU + 1
00255          DO 130 J = 1, N
00256             DO 120 I = MAX( K1-J, 1 ), K3
00257                A( I, J ) = A( I, J )*MUL
00258   120       CONTINUE
00259   130    CONTINUE
00260 *
00261       ELSE IF( ITYPE.EQ.6 ) THEN
00262 *
00263 *        Band matrix
00264 *
00265          K1 = KL + KU + 2
00266          K2 = KL + 1
00267          K3 = 2*KL + KU + 1
00268          K4 = KL + KU + 1 + M
00269          DO 150 J = 1, N
00270             DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
00271                A( I, J ) = A( I, J )*MUL
00272   140       CONTINUE
00273   150    CONTINUE
00274 *
00275       END IF
00276 *
00277       IF( .NOT.DONE )
00278      $   GO TO 10
00279 *
00280       RETURN
00281 *
00282 *     End of SLASCL
00283 *
00284       END