KTH framework for Nek5000 toolboxes; testing version  0.0.1
dtrmm.f
Go to the documentation of this file.
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
dtrmm
subroutine dtrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
Definition: dtrmm.f:3
xerbla
subroutine xerbla(SRNAME, INFO)
Definition: xerbla.f:2