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