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