![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b STFSM 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download STFSM + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/stfsm.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/stfsm.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/stfsm.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE STFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, 00022 * B, LDB ) 00023 * 00024 * .. Scalar Arguments .. 00025 * CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO 00026 * INTEGER LDB, M, N 00027 * REAL ALPHA 00028 * .. 00029 * .. Array Arguments .. 00030 * REAL A( 0: * ), B( 0: LDB-1, 0: * ) 00031 * .. 00032 * 00033 * 00034 *> \par Purpose: 00035 * ============= 00036 *> 00037 *> \verbatim 00038 *> 00039 *> Level 3 BLAS like routine for A in RFP Format. 00040 *> 00041 *> STFSM solves the matrix equation 00042 *> 00043 *> op( A )*X = alpha*B or X*op( A ) = alpha*B 00044 *> 00045 *> where alpha is a scalar, X and B are m by n matrices, A is a unit, or 00046 *> non-unit, upper or lower triangular matrix and op( A ) is one of 00047 *> 00048 *> op( A ) = A or op( A ) = A**T. 00049 *> 00050 *> A is in Rectangular Full Packed (RFP) Format. 00051 *> 00052 *> The matrix X is overwritten on B. 00053 *> \endverbatim 00054 * 00055 * Arguments: 00056 * ========== 00057 * 00058 *> \param[in] TRANSR 00059 *> \verbatim 00060 *> TRANSR is CHARACTER*1 00061 *> = 'N': The Normal Form of RFP A is stored; 00062 *> = 'T': The Transpose Form of RFP A is stored. 00063 *> \endverbatim 00064 *> 00065 *> \param[in] SIDE 00066 *> \verbatim 00067 *> SIDE is CHARACTER*1 00068 *> On entry, SIDE specifies whether op( A ) appears on the left 00069 *> or right of X as follows: 00070 *> 00071 *> SIDE = 'L' or 'l' op( A )*X = alpha*B. 00072 *> 00073 *> SIDE = 'R' or 'r' X*op( A ) = alpha*B. 00074 *> 00075 *> Unchanged on exit. 00076 *> \endverbatim 00077 *> 00078 *> \param[in] UPLO 00079 *> \verbatim 00080 *> UPLO is CHARACTER*1 00081 *> On entry, UPLO specifies whether the RFP matrix A came from 00082 *> an upper or lower triangular matrix as follows: 00083 *> UPLO = 'U' or 'u' RFP A came from an upper triangular matrix 00084 *> UPLO = 'L' or 'l' RFP A came from a lower triangular matrix 00085 *> 00086 *> Unchanged on exit. 00087 *> \endverbatim 00088 *> 00089 *> \param[in] TRANS 00090 *> \verbatim 00091 *> TRANS is CHARACTER*1 00092 *> On entry, TRANS specifies the form of op( A ) to be used 00093 *> in the matrix multiplication as follows: 00094 *> 00095 *> TRANS = 'N' or 'n' op( A ) = A. 00096 *> 00097 *> TRANS = 'T' or 't' op( A ) = A'. 00098 *> 00099 *> Unchanged on exit. 00100 *> \endverbatim 00101 *> 00102 *> \param[in] DIAG 00103 *> \verbatim 00104 *> DIAG is CHARACTER*1 00105 *> On entry, DIAG specifies whether or not RFP A is unit 00106 *> triangular as follows: 00107 *> 00108 *> DIAG = 'U' or 'u' A is assumed to be unit triangular. 00109 *> 00110 *> DIAG = 'N' or 'n' A is not assumed to be unit 00111 *> triangular. 00112 *> 00113 *> Unchanged on exit. 00114 *> \endverbatim 00115 *> 00116 *> \param[in] M 00117 *> \verbatim 00118 *> M is INTEGER 00119 *> On entry, M specifies the number of rows of B. M must be at 00120 *> least zero. 00121 *> Unchanged on exit. 00122 *> \endverbatim 00123 *> 00124 *> \param[in] N 00125 *> \verbatim 00126 *> N is INTEGER 00127 *> On entry, N specifies the number of columns of B. N must be 00128 *> at least zero. 00129 *> Unchanged on exit. 00130 *> \endverbatim 00131 *> 00132 *> \param[in] ALPHA 00133 *> \verbatim 00134 *> ALPHA is REAL 00135 *> On entry, ALPHA specifies the scalar alpha. When alpha is 00136 *> zero then A is not referenced and B need not be set before 00137 *> entry. 00138 *> Unchanged on exit. 00139 *> \endverbatim 00140 *> 00141 *> \param[in] A 00142 *> \verbatim 00143 *> A is REAL array, dimension (NT) 00144 *> NT = N*(N+1)/2. On entry, the matrix A in RFP Format. 00145 *> RFP Format is described by TRANSR, UPLO and N as follows: 00146 *> If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; 00147 *> K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If 00148 *> TRANSR = 'T' then RFP is the transpose of RFP A as 00149 *> defined when TRANSR = 'N'. The contents of RFP A are defined 00150 *> by UPLO as follows: If UPLO = 'U' the RFP A contains the NT 00151 *> elements of upper packed A either in normal or 00152 *> transpose Format. If UPLO = 'L' the RFP A contains 00153 *> the NT elements of lower packed A either in normal or 00154 *> transpose Format. The LDA of RFP A is (N+1)/2 when 00155 *> TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is 00156 *> even and is N when is odd. 00157 *> See the Note below for more details. Unchanged on exit. 00158 *> \endverbatim 00159 *> 00160 *> \param[in,out] B 00161 *> \verbatim 00162 *> B is REAL array, DIMENSION (LDB,N) 00163 *> Before entry, the leading m by n part of the array B must 00164 *> contain the right-hand side matrix B, and on exit is 00165 *> overwritten by the solution matrix X. 00166 *> \endverbatim 00167 *> 00168 *> \param[in] LDB 00169 *> \verbatim 00170 *> LDB is INTEGER 00171 *> On entry, LDB specifies the first dimension of B as declared 00172 *> in the calling (sub) program. LDB must be at least 00173 *> max( 1, m ). 00174 *> Unchanged on exit. 00175 *> \endverbatim 00176 * 00177 * Authors: 00178 * ======== 00179 * 00180 *> \author Univ. of Tennessee 00181 *> \author Univ. of California Berkeley 00182 *> \author Univ. of Colorado Denver 00183 *> \author NAG Ltd. 00184 * 00185 *> \date November 2011 00186 * 00187 *> \ingroup realOTHERcomputational 00188 * 00189 *> \par Further Details: 00190 * ===================== 00191 *> 00192 *> \verbatim 00193 *> 00194 *> We first consider Rectangular Full Packed (RFP) Format when N is 00195 *> even. We give an example where N = 6. 00196 *> 00197 *> AP is Upper AP is Lower 00198 *> 00199 *> 00 01 02 03 04 05 00 00200 *> 11 12 13 14 15 10 11 00201 *> 22 23 24 25 20 21 22 00202 *> 33 34 35 30 31 32 33 00203 *> 44 45 40 41 42 43 44 00204 *> 55 50 51 52 53 54 55 00205 *> 00206 *> 00207 *> Let TRANSR = 'N'. RFP holds AP as follows: 00208 *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last 00209 *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of 00210 *> the transpose of the first three columns of AP upper. 00211 *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first 00212 *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of 00213 *> the transpose of the last three columns of AP lower. 00214 *> This covers the case N even and TRANSR = 'N'. 00215 *> 00216 *> RFP A RFP A 00217 *> 00218 *> 03 04 05 33 43 53 00219 *> 13 14 15 00 44 54 00220 *> 23 24 25 10 11 55 00221 *> 33 34 35 20 21 22 00222 *> 00 44 45 30 31 32 00223 *> 01 11 55 40 41 42 00224 *> 02 12 22 50 51 52 00225 *> 00226 *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the 00227 *> transpose of RFP A above. One therefore gets: 00228 *> 00229 *> 00230 *> RFP A RFP A 00231 *> 00232 *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50 00233 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51 00234 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52 00235 *> 00236 *> 00237 *> We then consider Rectangular Full Packed (RFP) Format when N is 00238 *> odd. We give an example where N = 5. 00239 *> 00240 *> AP is Upper AP is Lower 00241 *> 00242 *> 00 01 02 03 04 00 00243 *> 11 12 13 14 10 11 00244 *> 22 23 24 20 21 22 00245 *> 33 34 30 31 32 33 00246 *> 44 40 41 42 43 44 00247 *> 00248 *> 00249 *> Let TRANSR = 'N'. RFP holds AP as follows: 00250 *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last 00251 *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of 00252 *> the transpose of the first two columns of AP upper. 00253 *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first 00254 *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of 00255 *> the transpose of the last two columns of AP lower. 00256 *> This covers the case N odd and TRANSR = 'N'. 00257 *> 00258 *> RFP A RFP A 00259 *> 00260 *> 02 03 04 00 33 43 00261 *> 12 13 14 10 11 44 00262 *> 22 23 24 20 21 22 00263 *> 00 33 34 30 31 32 00264 *> 01 11 44 40 41 42 00265 *> 00266 *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the 00267 *> transpose of RFP A above. One therefore gets: 00268 *> 00269 *> RFP A RFP A 00270 *> 00271 *> 02 12 22 00 01 00 10 20 30 40 50 00272 *> 03 13 23 33 11 33 11 21 31 41 51 00273 *> 04 14 24 34 44 43 44 22 32 42 52 00274 *> \endverbatim 00275 * 00276 * ===================================================================== 00277 SUBROUTINE STFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, 00278 $ B, LDB ) 00279 * 00280 * -- LAPACK computational routine (version 3.4.0) -- 00281 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00282 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00283 * November 2011 00284 * 00285 * .. Scalar Arguments .. 00286 CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO 00287 INTEGER LDB, M, N 00288 REAL ALPHA 00289 * .. 00290 * .. Array Arguments .. 00291 REAL A( 0: * ), B( 0: LDB-1, 0: * ) 00292 * .. 00293 * 00294 * ===================================================================== 00295 * 00296 * .. 00297 * .. Parameters .. 00298 REAL ONE, ZERO 00299 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00300 * .. 00301 * .. Local Scalars .. 00302 LOGICAL LOWER, LSIDE, MISODD, NISODD, NORMALTRANSR, 00303 $ NOTRANS 00304 INTEGER M1, M2, N1, N2, K, INFO, I, J 00305 * .. 00306 * .. External Functions .. 00307 LOGICAL LSAME 00308 EXTERNAL LSAME 00309 * .. 00310 * .. External Subroutines .. 00311 EXTERNAL SGEMM, STRSM, XERBLA 00312 * .. 00313 * .. Intrinsic Functions .. 00314 INTRINSIC MAX, MOD 00315 * .. 00316 * .. Executable Statements .. 00317 * 00318 * Test the input parameters. 00319 * 00320 INFO = 0 00321 NORMALTRANSR = LSAME( TRANSR, 'N' ) 00322 LSIDE = LSAME( SIDE, 'L' ) 00323 LOWER = LSAME( UPLO, 'L' ) 00324 NOTRANS = LSAME( TRANS, 'N' ) 00325 IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN 00326 INFO = -1 00327 ELSE IF( .NOT.LSIDE .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 00328 INFO = -2 00329 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN 00330 INFO = -3 00331 ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN 00332 INFO = -4 00333 ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) 00334 $ THEN 00335 INFO = -5 00336 ELSE IF( M.LT.0 ) THEN 00337 INFO = -6 00338 ELSE IF( N.LT.0 ) THEN 00339 INFO = -7 00340 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN 00341 INFO = -11 00342 END IF 00343 IF( INFO.NE.0 ) THEN 00344 CALL XERBLA( 'STFSM ', -INFO ) 00345 RETURN 00346 END IF 00347 * 00348 * Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) 00349 * 00350 IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) 00351 $ RETURN 00352 * 00353 * Quick return when ALPHA.EQ.(0D+0) 00354 * 00355 IF( ALPHA.EQ.ZERO ) THEN 00356 DO 20 J = 0, N - 1 00357 DO 10 I = 0, M - 1 00358 B( I, J ) = ZERO 00359 10 CONTINUE 00360 20 CONTINUE 00361 RETURN 00362 END IF 00363 * 00364 IF( LSIDE ) THEN 00365 * 00366 * SIDE = 'L' 00367 * 00368 * A is M-by-M. 00369 * If M is odd, set NISODD = .TRUE., and M1 and M2. 00370 * If M is even, NISODD = .FALSE., and M. 00371 * 00372 IF( MOD( M, 2 ).EQ.0 ) THEN 00373 MISODD = .FALSE. 00374 K = M / 2 00375 ELSE 00376 MISODD = .TRUE. 00377 IF( LOWER ) THEN 00378 M2 = M / 2 00379 M1 = M - M2 00380 ELSE 00381 M1 = M / 2 00382 M2 = M - M1 00383 END IF 00384 END IF 00385 * 00386 IF( MISODD ) THEN 00387 * 00388 * SIDE = 'L' and N is odd 00389 * 00390 IF( NORMALTRANSR ) THEN 00391 * 00392 * SIDE = 'L', N is odd, and TRANSR = 'N' 00393 * 00394 IF( LOWER ) THEN 00395 * 00396 * SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' 00397 * 00398 IF( NOTRANS ) THEN 00399 * 00400 * SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and 00401 * TRANS = 'N' 00402 * 00403 IF( M.EQ.1 ) THEN 00404 CALL STRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, 00405 $ A, M, B, LDB ) 00406 ELSE 00407 CALL STRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, 00408 $ A( 0 ), M, B, LDB ) 00409 CALL SGEMM( 'N', 'N', M2, N, M1, -ONE, A( M1 ), 00410 $ M, B, LDB, ALPHA, B( M1, 0 ), LDB ) 00411 CALL STRSM( 'L', 'U', 'T', DIAG, M2, N, ONE, 00412 $ A( M ), M, B( M1, 0 ), LDB ) 00413 END IF 00414 * 00415 ELSE 00416 * 00417 * SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and 00418 * TRANS = 'T' 00419 * 00420 IF( M.EQ.1 ) THEN 00421 CALL STRSM( 'L', 'L', 'T', DIAG, M1, N, ALPHA, 00422 $ A( 0 ), M, B, LDB ) 00423 ELSE 00424 CALL STRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, 00425 $ A( M ), M, B( M1, 0 ), LDB ) 00426 CALL SGEMM( 'T', 'N', M1, N, M2, -ONE, A( M1 ), 00427 $ M, B( M1, 0 ), LDB, ALPHA, B, LDB ) 00428 CALL STRSM( 'L', 'L', 'T', DIAG, M1, N, ONE, 00429 $ A( 0 ), M, B, LDB ) 00430 END IF 00431 * 00432 END IF 00433 * 00434 ELSE 00435 * 00436 * SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' 00437 * 00438 IF( .NOT.NOTRANS ) THEN 00439 * 00440 * SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and 00441 * TRANS = 'N' 00442 * 00443 CALL STRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, 00444 $ A( M2 ), M, B, LDB ) 00445 CALL SGEMM( 'T', 'N', M2, N, M1, -ONE, A( 0 ), M, 00446 $ B, LDB, ALPHA, B( M1, 0 ), LDB ) 00447 CALL STRSM( 'L', 'U', 'T', DIAG, M2, N, ONE, 00448 $ A( M1 ), M, B( M1, 0 ), LDB ) 00449 * 00450 ELSE 00451 * 00452 * SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and 00453 * TRANS = 'T' 00454 * 00455 CALL STRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, 00456 $ A( M1 ), M, B( M1, 0 ), LDB ) 00457 CALL SGEMM( 'N', 'N', M1, N, M2, -ONE, A( 0 ), M, 00458 $ B( M1, 0 ), LDB, ALPHA, B, LDB ) 00459 CALL STRSM( 'L', 'L', 'T', DIAG, M1, N, ONE, 00460 $ A( M2 ), M, B, LDB ) 00461 * 00462 END IF 00463 * 00464 END IF 00465 * 00466 ELSE 00467 * 00468 * SIDE = 'L', N is odd, and TRANSR = 'T' 00469 * 00470 IF( LOWER ) THEN 00471 * 00472 * SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L' 00473 * 00474 IF( NOTRANS ) THEN 00475 * 00476 * SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and 00477 * TRANS = 'N' 00478 * 00479 IF( M.EQ.1 ) THEN 00480 CALL STRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, 00481 $ A( 0 ), M1, B, LDB ) 00482 ELSE 00483 CALL STRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, 00484 $ A( 0 ), M1, B, LDB ) 00485 CALL SGEMM( 'T', 'N', M2, N, M1, -ONE, 00486 $ A( M1*M1 ), M1, B, LDB, ALPHA, 00487 $ B( M1, 0 ), LDB ) 00488 CALL STRSM( 'L', 'L', 'N', DIAG, M2, N, ONE, 00489 $ A( 1 ), M1, B( M1, 0 ), LDB ) 00490 END IF 00491 * 00492 ELSE 00493 * 00494 * SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and 00495 * TRANS = 'T' 00496 * 00497 IF( M.EQ.1 ) THEN 00498 CALL STRSM( 'L', 'U', 'N', DIAG, M1, N, ALPHA, 00499 $ A( 0 ), M1, B, LDB ) 00500 ELSE 00501 CALL STRSM( 'L', 'L', 'T', DIAG, M2, N, ALPHA, 00502 $ A( 1 ), M1, B( M1, 0 ), LDB ) 00503 CALL SGEMM( 'N', 'N', M1, N, M2, -ONE, 00504 $ A( M1*M1 ), M1, B( M1, 0 ), LDB, 00505 $ ALPHA, B, LDB ) 00506 CALL STRSM( 'L', 'U', 'N', DIAG, M1, N, ONE, 00507 $ A( 0 ), M1, B, LDB ) 00508 END IF 00509 * 00510 END IF 00511 * 00512 ELSE 00513 * 00514 * SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U' 00515 * 00516 IF( .NOT.NOTRANS ) THEN 00517 * 00518 * SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and 00519 * TRANS = 'N' 00520 * 00521 CALL STRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, 00522 $ A( M2*M2 ), M2, B, LDB ) 00523 CALL SGEMM( 'N', 'N', M2, N, M1, -ONE, A( 0 ), M2, 00524 $ B, LDB, ALPHA, B( M1, 0 ), LDB ) 00525 CALL STRSM( 'L', 'L', 'N', DIAG, M2, N, ONE, 00526 $ A( M1*M2 ), M2, B( M1, 0 ), LDB ) 00527 * 00528 ELSE 00529 * 00530 * SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and 00531 * TRANS = 'T' 00532 * 00533 CALL STRSM( 'L', 'L', 'T', DIAG, M2, N, ALPHA, 00534 $ A( M1*M2 ), M2, B( M1, 0 ), LDB ) 00535 CALL SGEMM( 'T', 'N', M1, N, M2, -ONE, A( 0 ), M2, 00536 $ B( M1, 0 ), LDB, ALPHA, B, LDB ) 00537 CALL STRSM( 'L', 'U', 'N', DIAG, M1, N, ONE, 00538 $ A( M2*M2 ), M2, B, LDB ) 00539 * 00540 END IF 00541 * 00542 END IF 00543 * 00544 END IF 00545 * 00546 ELSE 00547 * 00548 * SIDE = 'L' and N is even 00549 * 00550 IF( NORMALTRANSR ) THEN 00551 * 00552 * SIDE = 'L', N is even, and TRANSR = 'N' 00553 * 00554 IF( LOWER ) THEN 00555 * 00556 * SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' 00557 * 00558 IF( NOTRANS ) THEN 00559 * 00560 * SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', 00561 * and TRANS = 'N' 00562 * 00563 CALL STRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, 00564 $ A( 1 ), M+1, B, LDB ) 00565 CALL SGEMM( 'N', 'N', K, N, K, -ONE, A( K+1 ), 00566 $ M+1, B, LDB, ALPHA, B( K, 0 ), LDB ) 00567 CALL STRSM( 'L', 'U', 'T', DIAG, K, N, ONE, 00568 $ A( 0 ), M+1, B( K, 0 ), LDB ) 00569 * 00570 ELSE 00571 * 00572 * SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', 00573 * and TRANS = 'T' 00574 * 00575 CALL STRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, 00576 $ A( 0 ), M+1, B( K, 0 ), LDB ) 00577 CALL SGEMM( 'T', 'N', K, N, K, -ONE, A( K+1 ), 00578 $ M+1, B( K, 0 ), LDB, ALPHA, B, LDB ) 00579 CALL STRSM( 'L', 'L', 'T', DIAG, K, N, ONE, 00580 $ A( 1 ), M+1, B, LDB ) 00581 * 00582 END IF 00583 * 00584 ELSE 00585 * 00586 * SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' 00587 * 00588 IF( .NOT.NOTRANS ) THEN 00589 * 00590 * SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', 00591 * and TRANS = 'N' 00592 * 00593 CALL STRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, 00594 $ A( K+1 ), M+1, B, LDB ) 00595 CALL SGEMM( 'T', 'N', K, N, K, -ONE, A( 0 ), M+1, 00596 $ B, LDB, ALPHA, B( K, 0 ), LDB ) 00597 CALL STRSM( 'L', 'U', 'T', DIAG, K, N, ONE, 00598 $ A( K ), M+1, B( K, 0 ), LDB ) 00599 * 00600 ELSE 00601 * 00602 * SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', 00603 * and TRANS = 'T' 00604 CALL STRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, 00605 $ A( K ), M+1, B( K, 0 ), LDB ) 00606 CALL SGEMM( 'N', 'N', K, N, K, -ONE, A( 0 ), M+1, 00607 $ B( K, 0 ), LDB, ALPHA, B, LDB ) 00608 CALL STRSM( 'L', 'L', 'T', DIAG, K, N, ONE, 00609 $ A( K+1 ), M+1, B, LDB ) 00610 * 00611 END IF 00612 * 00613 END IF 00614 * 00615 ELSE 00616 * 00617 * SIDE = 'L', N is even, and TRANSR = 'T' 00618 * 00619 IF( LOWER ) THEN 00620 * 00621 * SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L' 00622 * 00623 IF( NOTRANS ) THEN 00624 * 00625 * SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', 00626 * and TRANS = 'N' 00627 * 00628 CALL STRSM( 'L', 'U', 'T', DIAG, K, N, ALPHA, 00629 $ A( K ), K, B, LDB ) 00630 CALL SGEMM( 'T', 'N', K, N, K, -ONE, 00631 $ A( K*( K+1 ) ), K, B, LDB, ALPHA, 00632 $ B( K, 0 ), LDB ) 00633 CALL STRSM( 'L', 'L', 'N', DIAG, K, N, ONE, 00634 $ A( 0 ), K, B( K, 0 ), LDB ) 00635 * 00636 ELSE 00637 * 00638 * SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', 00639 * and TRANS = 'T' 00640 * 00641 CALL STRSM( 'L', 'L', 'T', DIAG, K, N, ALPHA, 00642 $ A( 0 ), K, B( K, 0 ), LDB ) 00643 CALL SGEMM( 'N', 'N', K, N, K, -ONE, 00644 $ A( K*( K+1 ) ), K, B( K, 0 ), LDB, 00645 $ ALPHA, B, LDB ) 00646 CALL STRSM( 'L', 'U', 'N', DIAG, K, N, ONE, 00647 $ A( K ), K, B, LDB ) 00648 * 00649 END IF 00650 * 00651 ELSE 00652 * 00653 * SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U' 00654 * 00655 IF( .NOT.NOTRANS ) THEN 00656 * 00657 * SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', 00658 * and TRANS = 'N' 00659 * 00660 CALL STRSM( 'L', 'U', 'T', DIAG, K, N, ALPHA, 00661 $ A( K*( K+1 ) ), K, B, LDB ) 00662 CALL SGEMM( 'N', 'N', K, N, K, -ONE, A( 0 ), K, B, 00663 $ LDB, ALPHA, B( K, 0 ), LDB ) 00664 CALL STRSM( 'L', 'L', 'N', DIAG, K, N, ONE, 00665 $ A( K*K ), K, B( K, 0 ), LDB ) 00666 * 00667 ELSE 00668 * 00669 * SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', 00670 * and TRANS = 'T' 00671 * 00672 CALL STRSM( 'L', 'L', 'T', DIAG, K, N, ALPHA, 00673 $ A( K*K ), K, B( K, 0 ), LDB ) 00674 CALL SGEMM( 'T', 'N', K, N, K, -ONE, A( 0 ), K, 00675 $ B( K, 0 ), LDB, ALPHA, B, LDB ) 00676 CALL STRSM( 'L', 'U', 'N', DIAG, K, N, ONE, 00677 $ A( K*( K+1 ) ), K, B, LDB ) 00678 * 00679 END IF 00680 * 00681 END IF 00682 * 00683 END IF 00684 * 00685 END IF 00686 * 00687 ELSE 00688 * 00689 * SIDE = 'R' 00690 * 00691 * A is N-by-N. 00692 * If N is odd, set NISODD = .TRUE., and N1 and N2. 00693 * If N is even, NISODD = .FALSE., and K. 00694 * 00695 IF( MOD( N, 2 ).EQ.0 ) THEN 00696 NISODD = .FALSE. 00697 K = N / 2 00698 ELSE 00699 NISODD = .TRUE. 00700 IF( LOWER ) THEN 00701 N2 = N / 2 00702 N1 = N - N2 00703 ELSE 00704 N1 = N / 2 00705 N2 = N - N1 00706 END IF 00707 END IF 00708 * 00709 IF( NISODD ) THEN 00710 * 00711 * SIDE = 'R' and N is odd 00712 * 00713 IF( NORMALTRANSR ) THEN 00714 * 00715 * SIDE = 'R', N is odd, and TRANSR = 'N' 00716 * 00717 IF( LOWER ) THEN 00718 * 00719 * SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' 00720 * 00721 IF( NOTRANS ) THEN 00722 * 00723 * SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and 00724 * TRANS = 'N' 00725 * 00726 CALL STRSM( 'R', 'U', 'T', DIAG, M, N2, ALPHA, 00727 $ A( N ), N, B( 0, N1 ), LDB ) 00728 CALL SGEMM( 'N', 'N', M, N1, N2, -ONE, B( 0, N1 ), 00729 $ LDB, A( N1 ), N, ALPHA, B( 0, 0 ), 00730 $ LDB ) 00731 CALL STRSM( 'R', 'L', 'N', DIAG, M, N1, ONE, 00732 $ A( 0 ), N, B( 0, 0 ), LDB ) 00733 * 00734 ELSE 00735 * 00736 * SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and 00737 * TRANS = 'T' 00738 * 00739 CALL STRSM( 'R', 'L', 'T', DIAG, M, N1, ALPHA, 00740 $ A( 0 ), N, B( 0, 0 ), LDB ) 00741 CALL SGEMM( 'N', 'T', M, N2, N1, -ONE, B( 0, 0 ), 00742 $ LDB, A( N1 ), N, ALPHA, B( 0, N1 ), 00743 $ LDB ) 00744 CALL STRSM( 'R', 'U', 'N', DIAG, M, N2, ONE, 00745 $ A( N ), N, B( 0, N1 ), LDB ) 00746 * 00747 END IF 00748 * 00749 ELSE 00750 * 00751 * SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' 00752 * 00753 IF( NOTRANS ) THEN 00754 * 00755 * SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and 00756 * TRANS = 'N' 00757 * 00758 CALL STRSM( 'R', 'L', 'T', DIAG, M, N1, ALPHA, 00759 $ A( N2 ), N, B( 0, 0 ), LDB ) 00760 CALL SGEMM( 'N', 'N', M, N2, N1, -ONE, B( 0, 0 ), 00761 $ LDB, A( 0 ), N, ALPHA, B( 0, N1 ), 00762 $ LDB ) 00763 CALL STRSM( 'R', 'U', 'N', DIAG, M, N2, ONE, 00764 $ A( N1 ), N, B( 0, N1 ), LDB ) 00765 * 00766 ELSE 00767 * 00768 * SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and 00769 * TRANS = 'T' 00770 * 00771 CALL STRSM( 'R', 'U', 'T', DIAG, M, N2, ALPHA, 00772 $ A( N1 ), N, B( 0, N1 ), LDB ) 00773 CALL SGEMM( 'N', 'T', M, N1, N2, -ONE, B( 0, N1 ), 00774 $ LDB, A( 0 ), N, ALPHA, B( 0, 0 ), LDB ) 00775 CALL STRSM( 'R', 'L', 'N', DIAG, M, N1, ONE, 00776 $ A( N2 ), N, B( 0, 0 ), LDB ) 00777 * 00778 END IF 00779 * 00780 END IF 00781 * 00782 ELSE 00783 * 00784 * SIDE = 'R', N is odd, and TRANSR = 'T' 00785 * 00786 IF( LOWER ) THEN 00787 * 00788 * SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L' 00789 * 00790 IF( NOTRANS ) THEN 00791 * 00792 * SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and 00793 * TRANS = 'N' 00794 * 00795 CALL STRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, 00796 $ A( 1 ), N1, B( 0, N1 ), LDB ) 00797 CALL SGEMM( 'N', 'T', M, N1, N2, -ONE, B( 0, N1 ), 00798 $ LDB, A( N1*N1 ), N1, ALPHA, B( 0, 0 ), 00799 $ LDB ) 00800 CALL STRSM( 'R', 'U', 'T', DIAG, M, N1, ONE, 00801 $ A( 0 ), N1, B( 0, 0 ), LDB ) 00802 * 00803 ELSE 00804 * 00805 * SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and 00806 * TRANS = 'T' 00807 * 00808 CALL STRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, 00809 $ A( 0 ), N1, B( 0, 0 ), LDB ) 00810 CALL SGEMM( 'N', 'N', M, N2, N1, -ONE, B( 0, 0 ), 00811 $ LDB, A( N1*N1 ), N1, ALPHA, B( 0, N1 ), 00812 $ LDB ) 00813 CALL STRSM( 'R', 'L', 'T', DIAG, M, N2, ONE, 00814 $ A( 1 ), N1, B( 0, N1 ), LDB ) 00815 * 00816 END IF 00817 * 00818 ELSE 00819 * 00820 * SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U' 00821 * 00822 IF( NOTRANS ) THEN 00823 * 00824 * SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and 00825 * TRANS = 'N' 00826 * 00827 CALL STRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, 00828 $ A( N2*N2 ), N2, B( 0, 0 ), LDB ) 00829 CALL SGEMM( 'N', 'T', M, N2, N1, -ONE, B( 0, 0 ), 00830 $ LDB, A( 0 ), N2, ALPHA, B( 0, N1 ), 00831 $ LDB ) 00832 CALL STRSM( 'R', 'L', 'T', DIAG, M, N2, ONE, 00833 $ A( N1*N2 ), N2, B( 0, N1 ), LDB ) 00834 * 00835 ELSE 00836 * 00837 * SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and 00838 * TRANS = 'T' 00839 * 00840 CALL STRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, 00841 $ A( N1*N2 ), N2, B( 0, N1 ), LDB ) 00842 CALL SGEMM( 'N', 'N', M, N1, N2, -ONE, B( 0, N1 ), 00843 $ LDB, A( 0 ), N2, ALPHA, B( 0, 0 ), 00844 $ LDB ) 00845 CALL STRSM( 'R', 'U', 'T', DIAG, M, N1, ONE, 00846 $ A( N2*N2 ), N2, B( 0, 0 ), LDB ) 00847 * 00848 END IF 00849 * 00850 END IF 00851 * 00852 END IF 00853 * 00854 ELSE 00855 * 00856 * SIDE = 'R' and N is even 00857 * 00858 IF( NORMALTRANSR ) THEN 00859 * 00860 * SIDE = 'R', N is even, and TRANSR = 'N' 00861 * 00862 IF( LOWER ) THEN 00863 * 00864 * SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' 00865 * 00866 IF( NOTRANS ) THEN 00867 * 00868 * SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', 00869 * and TRANS = 'N' 00870 * 00871 CALL STRSM( 'R', 'U', 'T', DIAG, M, K, ALPHA, 00872 $ A( 0 ), N+1, B( 0, K ), LDB ) 00873 CALL SGEMM( 'N', 'N', M, K, K, -ONE, B( 0, K ), 00874 $ LDB, A( K+1 ), N+1, ALPHA, B( 0, 0 ), 00875 $ LDB ) 00876 CALL STRSM( 'R', 'L', 'N', DIAG, M, K, ONE, 00877 $ A( 1 ), N+1, B( 0, 0 ), LDB ) 00878 * 00879 ELSE 00880 * 00881 * SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', 00882 * and TRANS = 'T' 00883 * 00884 CALL STRSM( 'R', 'L', 'T', DIAG, M, K, ALPHA, 00885 $ A( 1 ), N+1, B( 0, 0 ), LDB ) 00886 CALL SGEMM( 'N', 'T', M, K, K, -ONE, B( 0, 0 ), 00887 $ LDB, A( K+1 ), N+1, ALPHA, B( 0, K ), 00888 $ LDB ) 00889 CALL STRSM( 'R', 'U', 'N', DIAG, M, K, ONE, 00890 $ A( 0 ), N+1, B( 0, K ), LDB ) 00891 * 00892 END IF 00893 * 00894 ELSE 00895 * 00896 * SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' 00897 * 00898 IF( NOTRANS ) THEN 00899 * 00900 * SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', 00901 * and TRANS = 'N' 00902 * 00903 CALL STRSM( 'R', 'L', 'T', DIAG, M, K, ALPHA, 00904 $ A( K+1 ), N+1, B( 0, 0 ), LDB ) 00905 CALL SGEMM( 'N', 'N', M, K, K, -ONE, B( 0, 0 ), 00906 $ LDB, A( 0 ), N+1, ALPHA, B( 0, K ), 00907 $ LDB ) 00908 CALL STRSM( 'R', 'U', 'N', DIAG, M, K, ONE, 00909 $ A( K ), N+1, B( 0, K ), LDB ) 00910 * 00911 ELSE 00912 * 00913 * SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', 00914 * and TRANS = 'T' 00915 * 00916 CALL STRSM( 'R', 'U', 'T', DIAG, M, K, ALPHA, 00917 $ A( K ), N+1, B( 0, K ), LDB ) 00918 CALL SGEMM( 'N', 'T', M, K, K, -ONE, B( 0, K ), 00919 $ LDB, A( 0 ), N+1, ALPHA, B( 0, 0 ), 00920 $ LDB ) 00921 CALL STRSM( 'R', 'L', 'N', DIAG, M, K, ONE, 00922 $ A( K+1 ), N+1, B( 0, 0 ), LDB ) 00923 * 00924 END IF 00925 * 00926 END IF 00927 * 00928 ELSE 00929 * 00930 * SIDE = 'R', N is even, and TRANSR = 'T' 00931 * 00932 IF( LOWER ) THEN 00933 * 00934 * SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L' 00935 * 00936 IF( NOTRANS ) THEN 00937 * 00938 * SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', 00939 * and TRANS = 'N' 00940 * 00941 CALL STRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, 00942 $ A( 0 ), K, B( 0, K ), LDB ) 00943 CALL SGEMM( 'N', 'T', M, K, K, -ONE, B( 0, K ), 00944 $ LDB, A( ( K+1 )*K ), K, ALPHA, 00945 $ B( 0, 0 ), LDB ) 00946 CALL STRSM( 'R', 'U', 'T', DIAG, M, K, ONE, 00947 $ A( K ), K, B( 0, 0 ), LDB ) 00948 * 00949 ELSE 00950 * 00951 * SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', 00952 * and TRANS = 'T' 00953 * 00954 CALL STRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, 00955 $ A( K ), K, B( 0, 0 ), LDB ) 00956 CALL SGEMM( 'N', 'N', M, K, K, -ONE, B( 0, 0 ), 00957 $ LDB, A( ( K+1 )*K ), K, ALPHA, 00958 $ B( 0, K ), LDB ) 00959 CALL STRSM( 'R', 'L', 'T', DIAG, M, K, ONE, 00960 $ A( 0 ), K, B( 0, K ), LDB ) 00961 * 00962 END IF 00963 * 00964 ELSE 00965 * 00966 * SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U' 00967 * 00968 IF( NOTRANS ) THEN 00969 * 00970 * SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', 00971 * and TRANS = 'N' 00972 * 00973 CALL STRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, 00974 $ A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) 00975 CALL SGEMM( 'N', 'T', M, K, K, -ONE, B( 0, 0 ), 00976 $ LDB, A( 0 ), K, ALPHA, B( 0, K ), LDB ) 00977 CALL STRSM( 'R', 'L', 'T', DIAG, M, K, ONE, 00978 $ A( K*K ), K, B( 0, K ), LDB ) 00979 * 00980 ELSE 00981 * 00982 * SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', 00983 * and TRANS = 'T' 00984 * 00985 CALL STRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, 00986 $ A( K*K ), K, B( 0, K ), LDB ) 00987 CALL SGEMM( 'N', 'N', M, K, K, -ONE, B( 0, K ), 00988 $ LDB, A( 0 ), K, ALPHA, B( 0, 0 ), LDB ) 00989 CALL STRSM( 'R', 'U', 'T', DIAG, M, K, ONE, 00990 $ A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) 00991 * 00992 END IF 00993 * 00994 END IF 00995 * 00996 END IF 00997 * 00998 END IF 00999 END IF 01000 * 01001 RETURN 01002 * 01003 * End of STFSM 01004 * 01005 END