vendor/gonum.org/v1/gonum/lapack/internal/testdata/netlib/dtrmm.f

   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