|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
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
1.7.3 
