KTH framework for Nek5000 toolboxes; testing version  0.0.1
dtrsv.f
Go to the documentation of this file.
1  SUBROUTINE dtrsv ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
2 * .. Scalar Arguments ..
3  INTEGER INCX, LDA, N
4  CHARACTER*1 DIAG, TRANS, UPLO
5 * .. Array Arguments ..
6  DOUBLE PRECISION A( LDA, * ), X( * )
7 * ..
8 *
9 * Purpose
10 * =======
11 *
12 * DTRSV solves one of the systems of equations
13 *
14 * A*x = b, or A'*x = b,
15 *
16 * where b and x are n element vectors and A is an n by n unit, or
17 * non-unit, upper or lower triangular matrix.
18 *
19 * No test for singularity or near-singularity is included in this
20 * routine. Such tests must be performed before calling this routine.
21 *
22 * Parameters
23 * ==========
24 *
25 * UPLO - CHARACTER*1.
26 * On entry, UPLO specifies whether the matrix is an upper or
27 * lower triangular matrix as follows:
28 *
29 * UPLO = 'U' or 'u' A is an upper triangular matrix.
30 *
31 * UPLO = 'L' or 'l' A is a lower triangular matrix.
32 *
33 * Unchanged on exit.
34 *
35 * TRANS - CHARACTER*1.
36 * On entry, TRANS specifies the equations to be solved as
37 * follows:
38 *
39 * TRANS = 'N' or 'n' A*x = b.
40 *
41 * TRANS = 'T' or 't' A'*x = b.
42 *
43 * TRANS = 'C' or 'c' A'*x = b.
44 *
45 * Unchanged on exit.
46 *
47 * DIAG - CHARACTER*1.
48 * On entry, DIAG specifies whether or not A is unit
49 * triangular as follows:
50 *
51 * DIAG = 'U' or 'u' A is assumed to be unit triangular.
52 *
53 * DIAG = 'N' or 'n' A is not assumed to be unit
54 * triangular.
55 *
56 * Unchanged on exit.
57 *
58 * N - INTEGER.
59 * On entry, N specifies the order of the matrix A.
60 * N must be at least zero.
61 * Unchanged on exit.
62 *
63 * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
64 * Before entry with UPLO = 'U' or 'u', the leading n by n
65 * upper triangular part of the array A must contain the upper
66 * triangular matrix and the strictly lower triangular part of
67 * A is not referenced.
68 * Before entry with UPLO = 'L' or 'l', the leading n by n
69 * lower triangular part of the array A must contain the lower
70 * triangular matrix and the strictly upper triangular part of
71 * A is not referenced.
72 * Note that when DIAG = 'U' or 'u', the diagonal elements of
73 * A are not referenced either, but are assumed to be unity.
74 * Unchanged on exit.
75 *
76 * LDA - INTEGER.
77 * On entry, LDA specifies the first dimension of A as declared
78 * in the calling (sub) program. LDA must be at least
79 * max( 1, n ).
80 * Unchanged on exit.
81 *
82 * X - DOUBLE PRECISION array of dimension at least
83 * ( 1 + ( n - 1 )*abs( INCX ) ).
84 * Before entry, the incremented array X must contain the n
85 * element right-hand side vector b. On exit, X is overwritten
86 * with the solution vector x.
87 *
88 * INCX - INTEGER.
89 * On entry, INCX specifies the increment for the elements of
90 * X. INCX must not be zero.
91 * Unchanged on exit.
92 *
93 *
94 * Level 2 Blas routine.
95 *
96 * -- Written on 22-October-1986.
97 * Jack Dongarra, Argonne National Lab.
98 * Jeremy Du Croz, Nag Central Office.
99 * Sven Hammarling, Nag Central Office.
100 * Richard Hanson, Sandia National Labs.
101 *
102 *
103 * .. Parameters ..
104  DOUBLE PRECISION ZERO
105  parameter( zero = 0.0d+0 )
106 * .. Local Scalars ..
107  DOUBLE PRECISION TEMP
108  INTEGER I, INFO, IX, J, JX, KX
109  LOGICAL NOUNIT
110 * .. External Functions ..
111  LOGICAL LSAME
112  EXTERNAL lsame
113 * .. External Subroutines ..
114  EXTERNAL xerbla
115 * .. Intrinsic Functions ..
116  INTRINSIC max
117 * ..
118 * .. Executable Statements ..
119 *
120 * Test the input parameters.
121 *
122  info = 0
123  IF ( .NOT.lsame( uplo , 'U' ).AND.
124  $ .NOT.lsame( uplo , 'L' ) )THEN
125  info = 1
126  ELSE IF( .NOT.lsame( trans, 'N' ).AND.
127  $ .NOT.lsame( trans, 'T' ).AND.
128  $ .NOT.lsame( trans, 'C' ) )THEN
129  info = 2
130  ELSE IF( .NOT.lsame( diag , 'U' ).AND.
131  $ .NOT.lsame( diag , 'N' ) )THEN
132  info = 3
133  ELSE IF( n.LT.0 )THEN
134  info = 4
135  ELSE IF( lda.LT.max( 1, n ) )THEN
136  info = 6
137  ELSE IF( incx.EQ.0 )THEN
138  info = 8
139  END IF
140  IF( info.NE.0 )THEN
141  CALL xerbla( 'DTRSV ', info )
142  RETURN
143  END IF
144 *
145 * Quick return if possible.
146 *
147  IF( n.EQ.0 )
148  $ RETURN
149 *
150  nounit = lsame( diag, 'N' )
151 *
152 * Set up the start point in X if the increment is not unity. This
153 * will be ( N - 1 )*INCX too small for descending loops.
154 *
155  IF( incx.LE.0 )THEN
156  kx = 1 - ( n - 1 )*incx
157  ELSE IF( incx.NE.1 )THEN
158  kx = 1
159  END IF
160 *
161 * Start the operations. In this version the elements of A are
162 * accessed sequentially with one pass through A.
163 *
164  IF( lsame( trans, 'N' ) )THEN
165 *
166 * Form x := inv( A )*x.
167 *
168  IF( lsame( uplo, 'U' ) )THEN
169  IF( incx.EQ.1 )THEN
170  DO 20, j = n, 1, -1
171  IF( x( j ).NE.zero )THEN
172  IF( nounit )
173  $ x( j ) = x( j )/a( j, j )
174  temp = x( j )
175  DO 10, i = j - 1, 1, -1
176  x( i ) = x( i ) - temp*a( i, j )
177  10 CONTINUE
178  END IF
179  20 CONTINUE
180  ELSE
181  jx = kx + ( n - 1 )*incx
182  DO 40, j = n, 1, -1
183  IF( x( jx ).NE.zero )THEN
184  IF( nounit )
185  $ x( jx ) = x( jx )/a( j, j )
186  temp = x( jx )
187  ix = jx
188  DO 30, i = j - 1, 1, -1
189  ix = ix - incx
190  x( ix ) = x( ix ) - temp*a( i, j )
191  30 CONTINUE
192  END IF
193  jx = jx - incx
194  40 CONTINUE
195  END IF
196  ELSE
197  IF( incx.EQ.1 )THEN
198  DO 60, j = 1, n
199  IF( x( j ).NE.zero )THEN
200  IF( nounit )
201  $ x( j ) = x( j )/a( j, j )
202  temp = x( j )
203  DO 50, i = j + 1, n
204  x( i ) = x( i ) - temp*a( i, j )
205  50 CONTINUE
206  END IF
207  60 CONTINUE
208  ELSE
209  jx = kx
210  DO 80, j = 1, n
211  IF( x( jx ).NE.zero )THEN
212  IF( nounit )
213  $ x( jx ) = x( jx )/a( j, j )
214  temp = x( jx )
215  ix = jx
216  DO 70, i = j + 1, n
217  ix = ix + incx
218  x( ix ) = x( ix ) - temp*a( i, j )
219  70 CONTINUE
220  END IF
221  jx = jx + incx
222  80 CONTINUE
223  END IF
224  END IF
225  ELSE
226 *
227 * Form x := inv( A' )*x.
228 *
229  IF( lsame( uplo, 'U' ) )THEN
230  IF( incx.EQ.1 )THEN
231  DO 100, j = 1, n
232  temp = x( j )
233  DO 90, i = 1, j - 1
234  temp = temp - a( i, j )*x( i )
235  90 CONTINUE
236  IF( nounit )
237  $ temp = temp/a( j, j )
238  x( j ) = temp
239  100 CONTINUE
240  ELSE
241  jx = kx
242  DO 120, j = 1, n
243  temp = x( jx )
244  ix = kx
245  DO 110, i = 1, j - 1
246  temp = temp - a( i, j )*x( ix )
247  ix = ix + incx
248  110 CONTINUE
249  IF( nounit )
250  $ temp = temp/a( j, j )
251  x( jx ) = temp
252  jx = jx + incx
253  120 CONTINUE
254  END IF
255  ELSE
256  IF( incx.EQ.1 )THEN
257  DO 140, j = n, 1, -1
258  temp = x( j )
259  DO 130, i = n, j + 1, -1
260  temp = temp - a( i, j )*x( i )
261  130 CONTINUE
262  IF( nounit )
263  $ temp = temp/a( j, j )
264  x( j ) = temp
265  140 CONTINUE
266  ELSE
267  kx = kx + ( n - 1 )*incx
268  jx = kx
269  DO 160, j = n, 1, -1
270  temp = x( jx )
271  ix = kx
272  DO 150, i = n, j + 1, -1
273  temp = temp - a( i, j )*x( ix )
274  ix = ix - incx
275  150 CONTINUE
276  IF( nounit )
277  $ temp = temp/a( j, j )
278  x( jx ) = temp
279  jx = jx - incx
280  160 CONTINUE
281  END IF
282  END IF
283  END IF
284 *
285  RETURN
286 *
287 * End of DTRSV .
288 *
289  END
dtrsv
subroutine dtrsv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
Definition: dtrsv.f:2
xerbla
subroutine xerbla(SRNAME, INFO)
Definition: xerbla.f:2