![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b STRSM 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) 00012 * 00013 * .. Scalar Arguments .. 00014 * REAL ALPHA 00015 * INTEGER LDA,LDB,M,N 00016 * CHARACTER DIAG,SIDE,TRANSA,UPLO 00017 * .. 00018 * .. Array Arguments .. 00019 * REAL A(LDA,*),B(LDB,*) 00020 * .. 00021 * 00022 * 00023 *> \par Purpose: 00024 * ============= 00025 *> 00026 *> \verbatim 00027 *> 00028 *> STRSM solves one of the matrix equations 00029 *> 00030 *> op( A )*X = alpha*B, or X*op( A ) = alpha*B, 00031 *> 00032 *> where alpha is a scalar, X and B are m by n matrices, A is a unit, or 00033 *> non-unit, upper or lower triangular matrix and op( A ) is one of 00034 *> 00035 *> op( A ) = A or op( A ) = A**T. 00036 *> 00037 *> The matrix X is overwritten on B. 00038 *> \endverbatim 00039 * 00040 * Arguments: 00041 * ========== 00042 * 00043 *> \param[in] SIDE 00044 *> \verbatim 00045 *> SIDE is CHARACTER*1 00046 *> On entry, SIDE specifies whether op( A ) appears on the left 00047 *> or right of X as follows: 00048 *> 00049 *> SIDE = 'L' or 'l' op( A )*X = alpha*B. 00050 *> 00051 *> SIDE = 'R' or 'r' X*op( A ) = alpha*B. 00052 *> \endverbatim 00053 *> 00054 *> \param[in] UPLO 00055 *> \verbatim 00056 *> UPLO is CHARACTER*1 00057 *> On entry, UPLO specifies whether the matrix A is an upper or 00058 *> lower triangular matrix as follows: 00059 *> 00060 *> UPLO = 'U' or 'u' A is an upper triangular matrix. 00061 *> 00062 *> UPLO = 'L' or 'l' A is a lower triangular matrix. 00063 *> \endverbatim 00064 *> 00065 *> \param[in] TRANSA 00066 *> \verbatim 00067 *> TRANSA is CHARACTER*1 00068 *> On entry, TRANSA specifies the form of op( A ) to be used in 00069 *> the matrix multiplication as follows: 00070 *> 00071 *> TRANSA = 'N' or 'n' op( A ) = A. 00072 *> 00073 *> TRANSA = 'T' or 't' op( A ) = A**T. 00074 *> 00075 *> TRANSA = 'C' or 'c' op( A ) = A**T. 00076 *> \endverbatim 00077 *> 00078 *> \param[in] DIAG 00079 *> \verbatim 00080 *> DIAG is CHARACTER*1 00081 *> On entry, DIAG specifies whether or not A is unit triangular 00082 *> as follows: 00083 *> 00084 *> DIAG = 'U' or 'u' A is assumed to be unit triangular. 00085 *> 00086 *> DIAG = 'N' or 'n' A is not assumed to be unit 00087 *> triangular. 00088 *> \endverbatim 00089 *> 00090 *> \param[in] M 00091 *> \verbatim 00092 *> M is INTEGER 00093 *> On entry, M specifies the number of rows of B. M must be at 00094 *> least zero. 00095 *> \endverbatim 00096 *> 00097 *> \param[in] N 00098 *> \verbatim 00099 *> N is INTEGER 00100 *> On entry, N specifies the number of columns of B. N must be 00101 *> at least zero. 00102 *> \endverbatim 00103 *> 00104 *> \param[in] ALPHA 00105 *> \verbatim 00106 *> ALPHA is REAL 00107 *> On entry, ALPHA specifies the scalar alpha. When alpha is 00108 *> zero then A is not referenced and B need not be set before 00109 *> entry. 00110 *> \endverbatim 00111 *> 00112 *> \param[in] A 00113 *> \verbatim 00114 *> A is REAL array of DIMENSION ( LDA, k ), 00115 *> where k is m when SIDE = 'L' or 'l' 00116 *> and k is n when SIDE = 'R' or 'r'. 00117 *> Before entry with UPLO = 'U' or 'u', the leading k by k 00118 *> upper triangular part of the array A must contain the upper 00119 *> triangular matrix and the strictly lower triangular part of 00120 *> A is not referenced. 00121 *> Before entry with UPLO = 'L' or 'l', the leading k by k 00122 *> lower triangular part of the array A must contain the lower 00123 *> triangular matrix and the strictly upper triangular part of 00124 *> A is not referenced. 00125 *> Note that when DIAG = 'U' or 'u', the diagonal elements of 00126 *> A are not referenced either, but are assumed to be unity. 00127 *> \endverbatim 00128 *> 00129 *> \param[in] LDA 00130 *> \verbatim 00131 *> LDA is INTEGER 00132 *> On entry, LDA specifies the first dimension of A as declared 00133 *> in the calling (sub) program. When SIDE = 'L' or 'l' then 00134 *> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' 00135 *> then LDA must be at least max( 1, n ). 00136 *> \endverbatim 00137 *> 00138 *> \param[in,out] B 00139 *> \verbatim 00140 *> B is REAL array of DIMENSION ( LDB, n ). 00141 *> Before entry, the leading m by n part of the array B must 00142 *> contain the right-hand side matrix B, and on exit is 00143 *> overwritten by the solution matrix X. 00144 *> \endverbatim 00145 *> 00146 *> \param[in] LDB 00147 *> \verbatim 00148 *> LDB is INTEGER 00149 *> On entry, LDB specifies the first dimension of B as declared 00150 *> in the calling (sub) program. LDB must be at least 00151 *> max( 1, m ). 00152 *> \endverbatim 00153 * 00154 * Authors: 00155 * ======== 00156 * 00157 *> \author Univ. of Tennessee 00158 *> \author Univ. of California Berkeley 00159 *> \author Univ. of Colorado Denver 00160 *> \author NAG Ltd. 00161 * 00162 *> \date November 2011 00163 * 00164 *> \ingroup single_blas_level3 00165 * 00166 *> \par Further Details: 00167 * ===================== 00168 *> 00169 *> \verbatim 00170 *> 00171 *> Level 3 Blas routine. 00172 *> 00173 *> 00174 *> -- Written on 8-February-1989. 00175 *> Jack Dongarra, Argonne National Laboratory. 00176 *> Iain Duff, AERE Harwell. 00177 *> Jeremy Du Croz, Numerical Algorithms Group Ltd. 00178 *> Sven Hammarling, Numerical Algorithms Group Ltd. 00179 *> \endverbatim 00180 *> 00181 * ===================================================================== 00182 SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) 00183 * 00184 * -- Reference BLAS level3 routine (version 3.4.0) -- 00185 * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 00186 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00187 * November 2011 00188 * 00189 * .. Scalar Arguments .. 00190 REAL ALPHA 00191 INTEGER LDA,LDB,M,N 00192 CHARACTER DIAG,SIDE,TRANSA,UPLO 00193 * .. 00194 * .. Array Arguments .. 00195 REAL A(LDA,*),B(LDB,*) 00196 * .. 00197 * 00198 * ===================================================================== 00199 * 00200 * .. External Functions .. 00201 LOGICAL LSAME 00202 EXTERNAL LSAME 00203 * .. 00204 * .. External Subroutines .. 00205 EXTERNAL XERBLA 00206 * .. 00207 * .. Intrinsic Functions .. 00208 INTRINSIC MAX 00209 * .. 00210 * .. Local Scalars .. 00211 REAL TEMP 00212 INTEGER I,INFO,J,K,NROWA 00213 LOGICAL LSIDE,NOUNIT,UPPER 00214 * .. 00215 * .. Parameters .. 00216 REAL ONE,ZERO 00217 PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) 00218 * .. 00219 * 00220 * Test the input parameters. 00221 * 00222 LSIDE = LSAME(SIDE,'L') 00223 IF (LSIDE) THEN 00224 NROWA = M 00225 ELSE 00226 NROWA = N 00227 END IF 00228 NOUNIT = LSAME(DIAG,'N') 00229 UPPER = LSAME(UPLO,'U') 00230 * 00231 INFO = 0 00232 IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN 00233 INFO = 1 00234 ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN 00235 INFO = 2 00236 ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. 00237 + (.NOT.LSAME(TRANSA,'T')) .AND. 00238 + (.NOT.LSAME(TRANSA,'C'))) THEN 00239 INFO = 3 00240 ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN 00241 INFO = 4 00242 ELSE IF (M.LT.0) THEN 00243 INFO = 5 00244 ELSE IF (N.LT.0) THEN 00245 INFO = 6 00246 ELSE IF (LDA.LT.MAX(1,NROWA)) THEN 00247 INFO = 9 00248 ELSE IF (LDB.LT.MAX(1,M)) THEN 00249 INFO = 11 00250 END IF 00251 IF (INFO.NE.0) THEN 00252 CALL XERBLA('STRSM ',INFO) 00253 RETURN 00254 END IF 00255 * 00256 * Quick return if possible. 00257 * 00258 IF (M.EQ.0 .OR. N.EQ.0) RETURN 00259 * 00260 * And when alpha.eq.zero. 00261 * 00262 IF (ALPHA.EQ.ZERO) THEN 00263 DO 20 J = 1,N 00264 DO 10 I = 1,M 00265 B(I,J) = ZERO 00266 10 CONTINUE 00267 20 CONTINUE 00268 RETURN 00269 END IF 00270 * 00271 * Start the operations. 00272 * 00273 IF (LSIDE) THEN 00274 IF (LSAME(TRANSA,'N')) THEN 00275 * 00276 * Form B := alpha*inv( A )*B. 00277 * 00278 IF (UPPER) THEN 00279 DO 60 J = 1,N 00280 IF (ALPHA.NE.ONE) THEN 00281 DO 30 I = 1,M 00282 B(I,J) = ALPHA*B(I,J) 00283 30 CONTINUE 00284 END IF 00285 DO 50 K = M,1,-1 00286 IF (B(K,J).NE.ZERO) THEN 00287 IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) 00288 DO 40 I = 1,K - 1 00289 B(I,J) = B(I,J) - B(K,J)*A(I,K) 00290 40 CONTINUE 00291 END IF 00292 50 CONTINUE 00293 60 CONTINUE 00294 ELSE 00295 DO 100 J = 1,N 00296 IF (ALPHA.NE.ONE) THEN 00297 DO 70 I = 1,M 00298 B(I,J) = ALPHA*B(I,J) 00299 70 CONTINUE 00300 END IF 00301 DO 90 K = 1,M 00302 IF (B(K,J).NE.ZERO) THEN 00303 IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) 00304 DO 80 I = K + 1,M 00305 B(I,J) = B(I,J) - B(K,J)*A(I,K) 00306 80 CONTINUE 00307 END IF 00308 90 CONTINUE 00309 100 CONTINUE 00310 END IF 00311 ELSE 00312 * 00313 * Form B := alpha*inv( A**T )*B. 00314 * 00315 IF (UPPER) THEN 00316 DO 130 J = 1,N 00317 DO 120 I = 1,M 00318 TEMP = ALPHA*B(I,J) 00319 DO 110 K = 1,I - 1 00320 TEMP = TEMP - A(K,I)*B(K,J) 00321 110 CONTINUE 00322 IF (NOUNIT) TEMP = TEMP/A(I,I) 00323 B(I,J) = TEMP 00324 120 CONTINUE 00325 130 CONTINUE 00326 ELSE 00327 DO 160 J = 1,N 00328 DO 150 I = M,1,-1 00329 TEMP = ALPHA*B(I,J) 00330 DO 140 K = I + 1,M 00331 TEMP = TEMP - A(K,I)*B(K,J) 00332 140 CONTINUE 00333 IF (NOUNIT) TEMP = TEMP/A(I,I) 00334 B(I,J) = TEMP 00335 150 CONTINUE 00336 160 CONTINUE 00337 END IF 00338 END IF 00339 ELSE 00340 IF (LSAME(TRANSA,'N')) THEN 00341 * 00342 * Form B := alpha*B*inv( A ). 00343 * 00344 IF (UPPER) THEN 00345 DO 210 J = 1,N 00346 IF (ALPHA.NE.ONE) THEN 00347 DO 170 I = 1,M 00348 B(I,J) = ALPHA*B(I,J) 00349 170 CONTINUE 00350 END IF 00351 DO 190 K = 1,J - 1 00352 IF (A(K,J).NE.ZERO) THEN 00353 DO 180 I = 1,M 00354 B(I,J) = B(I,J) - A(K,J)*B(I,K) 00355 180 CONTINUE 00356 END IF 00357 190 CONTINUE 00358 IF (NOUNIT) THEN 00359 TEMP = ONE/A(J,J) 00360 DO 200 I = 1,M 00361 B(I,J) = TEMP*B(I,J) 00362 200 CONTINUE 00363 END IF 00364 210 CONTINUE 00365 ELSE 00366 DO 260 J = N,1,-1 00367 IF (ALPHA.NE.ONE) THEN 00368 DO 220 I = 1,M 00369 B(I,J) = ALPHA*B(I,J) 00370 220 CONTINUE 00371 END IF 00372 DO 240 K = J + 1,N 00373 IF (A(K,J).NE.ZERO) THEN 00374 DO 230 I = 1,M 00375 B(I,J) = B(I,J) - A(K,J)*B(I,K) 00376 230 CONTINUE 00377 END IF 00378 240 CONTINUE 00379 IF (NOUNIT) THEN 00380 TEMP = ONE/A(J,J) 00381 DO 250 I = 1,M 00382 B(I,J) = TEMP*B(I,J) 00383 250 CONTINUE 00384 END IF 00385 260 CONTINUE 00386 END IF 00387 ELSE 00388 * 00389 * Form B := alpha*B*inv( A**T ). 00390 * 00391 IF (UPPER) THEN 00392 DO 310 K = N,1,-1 00393 IF (NOUNIT) THEN 00394 TEMP = ONE/A(K,K) 00395 DO 270 I = 1,M 00396 B(I,K) = TEMP*B(I,K) 00397 270 CONTINUE 00398 END IF 00399 DO 290 J = 1,K - 1 00400 IF (A(J,K).NE.ZERO) THEN 00401 TEMP = A(J,K) 00402 DO 280 I = 1,M 00403 B(I,J) = B(I,J) - TEMP*B(I,K) 00404 280 CONTINUE 00405 END IF 00406 290 CONTINUE 00407 IF (ALPHA.NE.ONE) THEN 00408 DO 300 I = 1,M 00409 B(I,K) = ALPHA*B(I,K) 00410 300 CONTINUE 00411 END IF 00412 310 CONTINUE 00413 ELSE 00414 DO 360 K = 1,N 00415 IF (NOUNIT) THEN 00416 TEMP = ONE/A(K,K) 00417 DO 320 I = 1,M 00418 B(I,K) = TEMP*B(I,K) 00419 320 CONTINUE 00420 END IF 00421 DO 340 J = K + 1,N 00422 IF (A(J,K).NE.ZERO) THEN 00423 TEMP = A(J,K) 00424 DO 330 I = 1,M 00425 B(I,J) = B(I,J) - TEMP*B(I,K) 00426 330 CONTINUE 00427 END IF 00428 340 CONTINUE 00429 IF (ALPHA.NE.ONE) THEN 00430 DO 350 I = 1,M 00431 B(I,K) = ALPHA*B(I,K) 00432 350 CONTINUE 00433 END IF 00434 360 CONTINUE 00435 END IF 00436 END IF 00437 END IF 00438 * 00439 RETURN 00440 * 00441 * End of STRSM . 00442 * 00443 END