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