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