1 SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, 2 $ B, LDB ) 3* .. Scalar Arguments .. 4 CHARACTER*1 SIDE, UPLO, TRANSA, DIAG 5 INTEGER M, N, LDA, LDB 6 DOUBLE PRECISION ALPHA 7* .. Array Arguments .. 8 DOUBLE PRECISION A( LDA, * ), B( LDB, * ) 9* .. 10* 11* Purpose 12* ======= 13* 14* DTRMM performs one of the matrix-matrix operations 15* 16* B := alpha*op( A )*B, or B := alpha*B*op( A ), 17* 18* where alpha is a scalar, B is an m by n matrix, A is a unit, or 19* non-unit, upper or lower triangular matrix and op( A ) is one of 20* 21* op( A ) = A or op( A ) = A'. 22* 23* Parameters 24* ========== 25* 26* SIDE - CHARACTER*1. 27* On entry, SIDE specifies whether op( A ) multiplies B from 28* the left or right as follows: 29* 30* SIDE = 'L' or 'l' B := alpha*op( A )*B. 31* 32* SIDE = 'R' or 'r' B := alpha*B*op( A ). 33* 34* Unchanged on exit. 35* 36* UPLO - CHARACTER*1. 37* On entry, UPLO specifies whether the matrix A is an upper or 38* lower triangular matrix as follows: 39* 40* UPLO = 'U' or 'u' A is an upper triangular matrix. 41* 42* UPLO = 'L' or 'l' A is a lower triangular matrix. 43* 44* Unchanged on exit. 45* 46* TRANSA - CHARACTER*1. 47* On entry, TRANSA specifies the form of op( A ) to be used in 48* the matrix multiplication as follows: 49* 50* TRANSA = 'N' or 'n' op( A ) = A. 51* 52* TRANSA = 'T' or 't' op( A ) = A'. 53* 54* TRANSA = 'C' or 'c' op( A ) = A'. 55* 56* Unchanged on exit. 57* 58* DIAG - CHARACTER*1. 59* On entry, DIAG specifies whether or not A is unit triangular 60* as follows: 61* 62* DIAG = 'U' or 'u' A is assumed to be unit triangular. 63* 64* DIAG = 'N' or 'n' A is not assumed to be unit 65* triangular. 66* 67* Unchanged on exit. 68* 69* M - INTEGER. 70* On entry, M specifies the number of rows of B. M must be at 71* least zero. 72* Unchanged on exit. 73* 74* N - INTEGER. 75* On entry, N specifies the number of columns of B. N must be 76* at least zero. 77* Unchanged on exit. 78* 79* ALPHA - DOUBLE PRECISION. 80* On entry, ALPHA specifies the scalar alpha. When alpha is 81* zero then A is not referenced and B need not be set before 82* entry. 83* Unchanged on exit. 84* 85* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m 86* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. 87* Before entry with UPLO = 'U' or 'u', the leading k by k 88* upper triangular part of the array A must contain the upper 89* triangular matrix and the strictly lower triangular part of 90* A is not referenced. 91* Before entry with UPLO = 'L' or 'l', the leading k by k 92* lower triangular part of the array A must contain the lower 93* triangular matrix and the strictly upper triangular part of 94* A is not referenced. 95* Note that when DIAG = 'U' or 'u', the diagonal elements of 96* A are not referenced either, but are assumed to be unity. 97* Unchanged on exit. 98* 99* LDA - INTEGER. 100* On entry, LDA specifies the first dimension of A as declared 101* in the calling (sub) program. When SIDE = 'L' or 'l' then 102* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' 103* then LDA must be at least max( 1, n ). 104* Unchanged on exit. 105* 106* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). 107* Before entry, the leading m by n part of the array B must 108* contain the matrix B, and on exit is overwritten by the 109* transformed matrix. 110* 111* LDB - INTEGER. 112* On entry, LDB specifies the first dimension of B as declared 113* in the calling (sub) program. LDB must be at least 114* max( 1, m ). 115* Unchanged on exit. 116* 117* 118* Level 3 Blas routine. 119* 120* -- Written on 8-February-1989. 121* Jack Dongarra, Argonne National Laboratory. 122* Iain Duff, AERE Harwell. 123* Jeremy Du Croz, Numerical Algorithms Group Ltd. 124* Sven Hammarling, Numerical Algorithms Group Ltd. 125* 126* 127* .. External Functions .. 128 LOGICAL LSAME 129 EXTERNAL LSAME 130* .. External Subroutines .. 131 EXTERNAL XERBLA 132* .. Intrinsic Functions .. 133 INTRINSIC MAX 134* .. Local Scalars .. 135 LOGICAL LSIDE, NOUNIT, UPPER 136 INTEGER I, INFO, J, K, NROWA 137 DOUBLE PRECISION TEMP 138* .. Parameters .. 139 DOUBLE PRECISION ONE , ZERO 140 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 141* .. 142* .. Executable Statements .. 143* 144* Test the input parameters. 145* 146 LSIDE = LSAME( SIDE , 'L' ) 147 IF( LSIDE )THEN 148 NROWA = M 149 ELSE 150 NROWA = N 151 END IF 152 NOUNIT = LSAME( DIAG , 'N' ) 153 UPPER = LSAME( UPLO , 'U' ) 154* 155 INFO = 0 156 IF( ( .NOT.LSIDE ).AND. 157 $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN 158 INFO = 1 159 ELSE IF( ( .NOT.UPPER ).AND. 160 $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN 161 INFO = 2 162 ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. 163 $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. 164 $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN 165 INFO = 3 166 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. 167 $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN 168 INFO = 4 169 ELSE IF( M .LT.0 )THEN 170 INFO = 5 171 ELSE IF( N .LT.0 )THEN 172 INFO = 6 173 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN 174 INFO = 9 175 ELSE IF( LDB.LT.MAX( 1, M ) )THEN 176 INFO = 11 177 END IF 178 IF( INFO.NE.0 )THEN 179 CALL XERBLA( 'DTRMM ', INFO ) 180 RETURN 181 END IF 182* 183* Quick return if possible. 184* 185 IF( N.EQ.0 ) 186 $ RETURN 187* 188* And when alpha.eq.zero. 189* 190 IF( ALPHA.EQ.ZERO )THEN 191 DO 20, J = 1, N 192 DO 10, I = 1, M 193 B( I, J ) = ZERO 194 10 CONTINUE 195 20 CONTINUE 196 RETURN 197 END IF 198* 199* Start the operations. 200* 201 IF( LSIDE )THEN 202 IF( LSAME( TRANSA, 'N' ) )THEN 203* 204* Form B := alpha*A*B. 205* 206 IF( UPPER )THEN 207 DO 50, J = 1, N 208 DO 40, K = 1, M 209 IF( B( K, J ).NE.ZERO )THEN 210 TEMP = ALPHA*B( K, J ) 211 DO 30, I = 1, K - 1 212 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 213 30 CONTINUE 214 IF( NOUNIT ) 215 $ TEMP = TEMP*A( K, K ) 216 B( K, J ) = TEMP 217 END IF 218 40 CONTINUE 219 50 CONTINUE 220 ELSE 221 DO 80, J = 1, N 222 DO 70 K = M, 1, -1 223 IF( B( K, J ).NE.ZERO )THEN 224 TEMP = ALPHA*B( K, J ) 225 B( K, J ) = TEMP 226 IF( NOUNIT ) 227 $ B( K, J ) = B( K, J )*A( K, K ) 228 DO 60, I = K + 1, M 229 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 230 60 CONTINUE 231 END IF 232 70 CONTINUE 233 80 CONTINUE 234 END IF 235 ELSE 236* 237* Form B := alpha*A'*B. 238* 239 IF( UPPER )THEN 240 DO 110, J = 1, N 241 DO 100, I = M, 1, -1 242 TEMP = B( I, J ) 243 IF( NOUNIT ) 244 $ TEMP = TEMP*A( I, I ) 245 DO 90, K = 1, I - 1 246 TEMP = TEMP + A( K, I )*B( K, J ) 247 90 CONTINUE 248 B( I, J ) = ALPHA*TEMP 249 100 CONTINUE 250 110 CONTINUE 251 ELSE 252 DO 140, J = 1, N 253 DO 130, I = 1, M 254 TEMP = B( I, J ) 255 IF( NOUNIT ) 256 $ TEMP = TEMP*A( I, I ) 257 DO 120, K = I + 1, M 258 TEMP = TEMP + A( K, I )*B( K, J ) 259 120 CONTINUE 260 B( I, J ) = ALPHA*TEMP 261 130 CONTINUE 262 140 CONTINUE 263 END IF 264 END IF 265 ELSE 266 IF( LSAME( TRANSA, 'N' ) )THEN 267* 268* Form B := alpha*B*A. 269* 270 IF( UPPER )THEN 271 DO 180, J = N, 1, -1 272 TEMP = ALPHA 273 IF( NOUNIT ) 274 $ TEMP = TEMP*A( J, J ) 275 DO 150, I = 1, M 276 B( I, J ) = TEMP*B( I, J ) 277 150 CONTINUE 278 DO 170, K = 1, J - 1 279 IF( A( K, J ).NE.ZERO )THEN 280 TEMP = ALPHA*A( K, J ) 281 DO 160, I = 1, M 282 B( I, J ) = B( I, J ) + TEMP*B( I, K ) 283 160 CONTINUE 284 END IF 285 170 CONTINUE 286 180 CONTINUE 287 ELSE 288 DO 220, J = 1, N 289 TEMP = ALPHA 290 IF( NOUNIT ) 291 $ TEMP = TEMP*A( J, J ) 292 DO 190, I = 1, M 293 B( I, J ) = TEMP*B( I, J ) 294 190 CONTINUE 295 DO 210, K = J + 1, N 296 IF( A( K, J ).NE.ZERO )THEN 297 TEMP = ALPHA*A( K, J ) 298 DO 200, I = 1, M 299 B( I, J ) = B( I, J ) + TEMP*B( I, K ) 300 200 CONTINUE 301 END IF 302 210 CONTINUE 303 220 CONTINUE 304 END IF 305 ELSE 306* 307* Form B := alpha*B*A'. 308* 309 IF( UPPER )THEN 310 DO 260, K = 1, N 311 DO 240, J = 1, K - 1 312 IF( A( J, K ).NE.ZERO )THEN 313 TEMP = ALPHA*A( J, K ) 314 DO 230, I = 1, M 315 B( I, J ) = B( I, J ) + TEMP*B( I, K ) 316 230 CONTINUE 317 END IF 318 240 CONTINUE 319 TEMP = ALPHA 320 IF( NOUNIT ) 321 $ TEMP = TEMP*A( K, K ) 322 IF( TEMP.NE.ONE )THEN 323 DO 250, I = 1, M 324 B( I, K ) = TEMP*B( I, K ) 325 250 CONTINUE 326 END IF 327 260 CONTINUE 328 ELSE 329 DO 300, K = N, 1, -1 330 DO 280, J = K + 1, N 331 IF( A( J, K ).NE.ZERO )THEN 332 TEMP = ALPHA*A( J, K ) 333 DO 270, I = 1, M 334 B( I, J ) = B( I, J ) + TEMP*B( I, K ) 335 270 CONTINUE 336 END IF 337 280 CONTINUE 338 TEMP = ALPHA 339 IF( NOUNIT ) 340 $ TEMP = TEMP*A( K, K ) 341 IF( TEMP.NE.ONE )THEN 342 DO 290, I = 1, M 343 B( I, K ) = TEMP*B( I, K ) 344 290 CONTINUE 345 END IF 346 300 CONTINUE 347 END IF 348 END IF 349 END IF 350* 351 RETURN 352* 353* End of DTRMM . 354* 355 END 356