![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b CTRSM 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 CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) 00012 * 00013 * .. Scalar Arguments .. 00014 * COMPLEX ALPHA 00015 * INTEGER LDA,LDB,M,N 00016 * CHARACTER DIAG,SIDE,TRANSA,UPLO 00017 * .. 00018 * .. Array Arguments .. 00019 * COMPLEX A(LDA,*),B(LDB,*) 00020 * .. 00021 * 00022 * 00023 *> \par Purpose: 00024 * ============= 00025 *> 00026 *> \verbatim 00027 *> 00028 *> CTRSM 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 or op( A ) = A**H. 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**H. 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 COMPLEX 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 COMPLEX 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 COMPLEX 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 complex_blas_level3 00165 * 00166 *> \par Further Details: 00167 * ===================== 00168 *> 00169 *> \verbatim 00170 *> 00171 *> Level 3 Blas routine. 00172 *> 00173 *> -- Written on 8-February-1989. 00174 *> Jack Dongarra, Argonne National Laboratory. 00175 *> Iain Duff, AERE Harwell. 00176 *> Jeremy Du Croz, Numerical Algorithms Group Ltd. 00177 *> Sven Hammarling, Numerical Algorithms Group Ltd. 00178 *> \endverbatim 00179 *> 00180 * ===================================================================== 00181 SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) 00182 * 00183 * -- Reference BLAS level3 routine (version 3.4.0) -- 00184 * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 00185 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00186 * November 2011 00187 * 00188 * .. Scalar Arguments .. 00189 COMPLEX ALPHA 00190 INTEGER LDA,LDB,M,N 00191 CHARACTER DIAG,SIDE,TRANSA,UPLO 00192 * .. 00193 * .. Array Arguments .. 00194 COMPLEX A(LDA,*),B(LDB,*) 00195 * .. 00196 * 00197 * ===================================================================== 00198 * 00199 * .. External Functions .. 00200 LOGICAL LSAME 00201 EXTERNAL LSAME 00202 * .. 00203 * .. External Subroutines .. 00204 EXTERNAL XERBLA 00205 * .. 00206 * .. Intrinsic Functions .. 00207 INTRINSIC CONJG,MAX 00208 * .. 00209 * .. Local Scalars .. 00210 COMPLEX TEMP 00211 INTEGER I,INFO,J,K,NROWA 00212 LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER 00213 * .. 00214 * .. Parameters .. 00215 COMPLEX ONE 00216 PARAMETER (ONE= (1.0E+0,0.0E+0)) 00217 COMPLEX ZERO 00218 PARAMETER (ZERO= (0.0E+0,0.0E+0)) 00219 * .. 00220 * 00221 * Test the input parameters. 00222 * 00223 LSIDE = LSAME(SIDE,'L') 00224 IF (LSIDE) THEN 00225 NROWA = M 00226 ELSE 00227 NROWA = N 00228 END IF 00229 NOCONJ = LSAME(TRANSA,'T') 00230 NOUNIT = LSAME(DIAG,'N') 00231 UPPER = LSAME(UPLO,'U') 00232 * 00233 INFO = 0 00234 IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN 00235 INFO = 1 00236 ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN 00237 INFO = 2 00238 ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. 00239 + (.NOT.LSAME(TRANSA,'T')) .AND. 00240 + (.NOT.LSAME(TRANSA,'C'))) THEN 00241 INFO = 3 00242 ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN 00243 INFO = 4 00244 ELSE IF (M.LT.0) THEN 00245 INFO = 5 00246 ELSE IF (N.LT.0) THEN 00247 INFO = 6 00248 ELSE IF (LDA.LT.MAX(1,NROWA)) THEN 00249 INFO = 9 00250 ELSE IF (LDB.LT.MAX(1,M)) THEN 00251 INFO = 11 00252 END IF 00253 IF (INFO.NE.0) THEN 00254 CALL XERBLA('CTRSM ',INFO) 00255 RETURN 00256 END IF 00257 * 00258 * Quick return if possible. 00259 * 00260 IF (M.EQ.0 .OR. N.EQ.0) RETURN 00261 * 00262 * And when alpha.eq.zero. 00263 * 00264 IF (ALPHA.EQ.ZERO) THEN 00265 DO 20 J = 1,N 00266 DO 10 I = 1,M 00267 B(I,J) = ZERO 00268 10 CONTINUE 00269 20 CONTINUE 00270 RETURN 00271 END IF 00272 * 00273 * Start the operations. 00274 * 00275 IF (LSIDE) THEN 00276 IF (LSAME(TRANSA,'N')) THEN 00277 * 00278 * Form B := alpha*inv( A )*B. 00279 * 00280 IF (UPPER) THEN 00281 DO 60 J = 1,N 00282 IF (ALPHA.NE.ONE) THEN 00283 DO 30 I = 1,M 00284 B(I,J) = ALPHA*B(I,J) 00285 30 CONTINUE 00286 END IF 00287 DO 50 K = M,1,-1 00288 IF (B(K,J).NE.ZERO) THEN 00289 IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) 00290 DO 40 I = 1,K - 1 00291 B(I,J) = B(I,J) - B(K,J)*A(I,K) 00292 40 CONTINUE 00293 END IF 00294 50 CONTINUE 00295 60 CONTINUE 00296 ELSE 00297 DO 100 J = 1,N 00298 IF (ALPHA.NE.ONE) THEN 00299 DO 70 I = 1,M 00300 B(I,J) = ALPHA*B(I,J) 00301 70 CONTINUE 00302 END IF 00303 DO 90 K = 1,M 00304 IF (B(K,J).NE.ZERO) THEN 00305 IF (NOUNIT) B(K,J) = B(K,J)/A(K,K) 00306 DO 80 I = K + 1,M 00307 B(I,J) = B(I,J) - B(K,J)*A(I,K) 00308 80 CONTINUE 00309 END IF 00310 90 CONTINUE 00311 100 CONTINUE 00312 END IF 00313 ELSE 00314 * 00315 * Form B := alpha*inv( A**T )*B 00316 * or B := alpha*inv( A**H )*B. 00317 * 00318 IF (UPPER) THEN 00319 DO 140 J = 1,N 00320 DO 130 I = 1,M 00321 TEMP = ALPHA*B(I,J) 00322 IF (NOCONJ) THEN 00323 DO 110 K = 1,I - 1 00324 TEMP = TEMP - A(K,I)*B(K,J) 00325 110 CONTINUE 00326 IF (NOUNIT) TEMP = TEMP/A(I,I) 00327 ELSE 00328 DO 120 K = 1,I - 1 00329 TEMP = TEMP - CONJG(A(K,I))*B(K,J) 00330 120 CONTINUE 00331 IF (NOUNIT) TEMP = TEMP/CONJG(A(I,I)) 00332 END IF 00333 B(I,J) = TEMP 00334 130 CONTINUE 00335 140 CONTINUE 00336 ELSE 00337 DO 180 J = 1,N 00338 DO 170 I = M,1,-1 00339 TEMP = ALPHA*B(I,J) 00340 IF (NOCONJ) THEN 00341 DO 150 K = I + 1,M 00342 TEMP = TEMP - A(K,I)*B(K,J) 00343 150 CONTINUE 00344 IF (NOUNIT) TEMP = TEMP/A(I,I) 00345 ELSE 00346 DO 160 K = I + 1,M 00347 TEMP = TEMP - CONJG(A(K,I))*B(K,J) 00348 160 CONTINUE 00349 IF (NOUNIT) TEMP = TEMP/CONJG(A(I,I)) 00350 END IF 00351 B(I,J) = TEMP 00352 170 CONTINUE 00353 180 CONTINUE 00354 END IF 00355 END IF 00356 ELSE 00357 IF (LSAME(TRANSA,'N')) THEN 00358 * 00359 * Form B := alpha*B*inv( A ). 00360 * 00361 IF (UPPER) THEN 00362 DO 230 J = 1,N 00363 IF (ALPHA.NE.ONE) THEN 00364 DO 190 I = 1,M 00365 B(I,J) = ALPHA*B(I,J) 00366 190 CONTINUE 00367 END IF 00368 DO 210 K = 1,J - 1 00369 IF (A(K,J).NE.ZERO) THEN 00370 DO 200 I = 1,M 00371 B(I,J) = B(I,J) - A(K,J)*B(I,K) 00372 200 CONTINUE 00373 END IF 00374 210 CONTINUE 00375 IF (NOUNIT) THEN 00376 TEMP = ONE/A(J,J) 00377 DO 220 I = 1,M 00378 B(I,J) = TEMP*B(I,J) 00379 220 CONTINUE 00380 END IF 00381 230 CONTINUE 00382 ELSE 00383 DO 280 J = N,1,-1 00384 IF (ALPHA.NE.ONE) THEN 00385 DO 240 I = 1,M 00386 B(I,J) = ALPHA*B(I,J) 00387 240 CONTINUE 00388 END IF 00389 DO 260 K = J + 1,N 00390 IF (A(K,J).NE.ZERO) THEN 00391 DO 250 I = 1,M 00392 B(I,J) = B(I,J) - A(K,J)*B(I,K) 00393 250 CONTINUE 00394 END IF 00395 260 CONTINUE 00396 IF (NOUNIT) THEN 00397 TEMP = ONE/A(J,J) 00398 DO 270 I = 1,M 00399 B(I,J) = TEMP*B(I,J) 00400 270 CONTINUE 00401 END IF 00402 280 CONTINUE 00403 END IF 00404 ELSE 00405 * 00406 * Form B := alpha*B*inv( A**T ) 00407 * or B := alpha*B*inv( A**H ). 00408 * 00409 IF (UPPER) THEN 00410 DO 330 K = N,1,-1 00411 IF (NOUNIT) THEN 00412 IF (NOCONJ) THEN 00413 TEMP = ONE/A(K,K) 00414 ELSE 00415 TEMP = ONE/CONJG(A(K,K)) 00416 END IF 00417 DO 290 I = 1,M 00418 B(I,K) = TEMP*B(I,K) 00419 290 CONTINUE 00420 END IF 00421 DO 310 J = 1,K - 1 00422 IF (A(J,K).NE.ZERO) THEN 00423 IF (NOCONJ) THEN 00424 TEMP = A(J,K) 00425 ELSE 00426 TEMP = CONJG(A(J,K)) 00427 END IF 00428 DO 300 I = 1,M 00429 B(I,J) = B(I,J) - TEMP*B(I,K) 00430 300 CONTINUE 00431 END IF 00432 310 CONTINUE 00433 IF (ALPHA.NE.ONE) THEN 00434 DO 320 I = 1,M 00435 B(I,K) = ALPHA*B(I,K) 00436 320 CONTINUE 00437 END IF 00438 330 CONTINUE 00439 ELSE 00440 DO 380 K = 1,N 00441 IF (NOUNIT) THEN 00442 IF (NOCONJ) THEN 00443 TEMP = ONE/A(K,K) 00444 ELSE 00445 TEMP = ONE/CONJG(A(K,K)) 00446 END IF 00447 DO 340 I = 1,M 00448 B(I,K) = TEMP*B(I,K) 00449 340 CONTINUE 00450 END IF 00451 DO 360 J = K + 1,N 00452 IF (A(J,K).NE.ZERO) THEN 00453 IF (NOCONJ) THEN 00454 TEMP = A(J,K) 00455 ELSE 00456 TEMP = CONJG(A(J,K)) 00457 END IF 00458 DO 350 I = 1,M 00459 B(I,J) = B(I,J) - TEMP*B(I,K) 00460 350 CONTINUE 00461 END IF 00462 360 CONTINUE 00463 IF (ALPHA.NE.ONE) THEN 00464 DO 370 I = 1,M 00465 B(I,K) = ALPHA*B(I,K) 00466 370 CONTINUE 00467 END IF 00468 380 CONTINUE 00469 END IF 00470 END IF 00471 END IF 00472 * 00473 RETURN 00474 * 00475 * End of CTRSM . 00476 * 00477 END