LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
derrgt.f
Go to the documentation of this file.
1 *> \brief \b DERRGT
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 DERRGT( PATH, NUNIT )
12 *
13 * .. Scalar Arguments ..
14 * CHARACTER*3 PATH
15 * INTEGER NUNIT
16 * ..
17 *
18 *
19 *> \par Purpose:
20 * =============
21 *>
22 *> \verbatim
23 *>
24 *> DERRGT tests the error exits for the DOUBLE PRECISION tridiagonal
25 *> routines.
26 *> \endverbatim
27 *
28 * Arguments:
29 * ==========
30 *
31 *> \param[in] PATH
32 *> \verbatim
33 *> PATH is CHARACTER*3
34 *> The LAPACK path name for the routines to be tested.
35 *> \endverbatim
36 *>
37 *> \param[in] NUNIT
38 *> \verbatim
39 *> NUNIT is INTEGER
40 *> The unit number for output.
41 *> \endverbatim
42 *
43 * Authors:
44 * ========
45 *
46 *> \author Univ. of Tennessee
47 *> \author Univ. of California Berkeley
48 *> \author Univ. of Colorado Denver
49 *> \author NAG Ltd.
50 *
51 *> \date November 2011
52 *
53 *> \ingroup double_lin
54 *
55 * =====================================================================
56  SUBROUTINE derrgt( PATH, NUNIT )
57 *
58 * -- LAPACK test routine (version 3.4.0) --
59 * -- LAPACK is a software package provided by Univ. of Tennessee, --
60 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
61 * November 2011
62 *
63 * .. Scalar Arguments ..
64  CHARACTER*3 path
65  INTEGER nunit
66 * ..
67 *
68 * =====================================================================
69 *
70 * .. Parameters ..
71  INTEGER nmax
72  parameter( nmax = 2 )
73 * ..
74 * .. Local Scalars ..
75  CHARACTER*2 c2
76  INTEGER info
77  DOUBLE PRECISION anorm, rcond
78 * ..
79 * .. Local Arrays ..
80  INTEGER ip( nmax ), iw( nmax )
81  DOUBLE PRECISION b( nmax ), c( nmax ), cf( nmax ), d( nmax ),
82  $ df( nmax ), e( nmax ), ef( nmax ), f( nmax ),
83  $ r1( nmax ), r2( nmax ), w( nmax ), x( nmax )
84 * ..
85 * .. External Functions ..
86  LOGICAL lsamen
87  EXTERNAL lsamen
88 * ..
89 * .. External Subroutines ..
90  EXTERNAL alaesm, chkxer, dgtcon, dgtrfs, dgttrf, dgttrs,
91  $ dptcon, dptrfs, dpttrf, dpttrs
92 * ..
93 * .. Scalars in Common ..
94  LOGICAL lerr, ok
95  CHARACTER*32 srnamt
96  INTEGER infot, nout
97 * ..
98 * .. Common blocks ..
99  common / infoc / infot, nout, ok, lerr
100  common / srnamc / srnamt
101 * ..
102 * .. Executable Statements ..
103 *
104  nout = nunit
105  WRITE( nout, fmt = * )
106  c2 = path( 2: 3 )
107  d( 1 ) = 1.d0
108  d( 2 ) = 2.d0
109  df( 1 ) = 1.d0
110  df( 2 ) = 2.d0
111  e( 1 ) = 3.d0
112  e( 2 ) = 4.d0
113  ef( 1 ) = 3.d0
114  ef( 2 ) = 4.d0
115  anorm = 1.0d0
116  ok = .true.
117 *
118  IF( lsamen( 2, c2, 'GT' ) ) THEN
119 *
120 * Test error exits for the general tridiagonal routines.
121 *
122 * DGTTRF
123 *
124  srnamt = 'DGTTRF'
125  infot = 1
126  CALL dgttrf( -1, c, d, e, f, ip, info )
127  CALL chkxer( 'DGTTRF', infot, nout, lerr, ok )
128 *
129 * DGTTRS
130 *
131  srnamt = 'DGTTRS'
132  infot = 1
133  CALL dgttrs( '/', 0, 0, c, d, e, f, ip, x, 1, info )
134  CALL chkxer( 'DGTTRS', infot, nout, lerr, ok )
135  infot = 2
136  CALL dgttrs( 'N', -1, 0, c, d, e, f, ip, x, 1, info )
137  CALL chkxer( 'DGTTRS', infot, nout, lerr, ok )
138  infot = 3
139  CALL dgttrs( 'N', 0, -1, c, d, e, f, ip, x, 1, info )
140  CALL chkxer( 'DGTTRS', infot, nout, lerr, ok )
141  infot = 10
142  CALL dgttrs( 'N', 2, 1, c, d, e, f, ip, x, 1, info )
143  CALL chkxer( 'DGTTRS', infot, nout, lerr, ok )
144 *
145 * DGTRFS
146 *
147  srnamt = 'DGTRFS'
148  infot = 1
149  CALL dgtrfs( '/', 0, 0, c, d, e, cf, df, ef, f, ip, b, 1, x, 1,
150  $ r1, r2, w, iw, info )
151  CALL chkxer( 'DGTRFS', infot, nout, lerr, ok )
152  infot = 2
153  CALL dgtrfs( 'N', -1, 0, c, d, e, cf, df, ef, f, ip, b, 1, x,
154  $ 1, r1, r2, w, iw, info )
155  CALL chkxer( 'DGTRFS', infot, nout, lerr, ok )
156  infot = 3
157  CALL dgtrfs( 'N', 0, -1, c, d, e, cf, df, ef, f, ip, b, 1, x,
158  $ 1, r1, r2, w, iw, info )
159  CALL chkxer( 'DGTRFS', infot, nout, lerr, ok )
160  infot = 13
161  CALL dgtrfs( 'N', 2, 1, c, d, e, cf, df, ef, f, ip, b, 1, x, 2,
162  $ r1, r2, w, iw, info )
163  CALL chkxer( 'DGTRFS', infot, nout, lerr, ok )
164  infot = 15
165  CALL dgtrfs( 'N', 2, 1, c, d, e, cf, df, ef, f, ip, b, 2, x, 1,
166  $ r1, r2, w, iw, info )
167  CALL chkxer( 'DGTRFS', infot, nout, lerr, ok )
168 *
169 * DGTCON
170 *
171  srnamt = 'DGTCON'
172  infot = 1
173  CALL dgtcon( '/', 0, c, d, e, f, ip, anorm, rcond, w, iw,
174  $ info )
175  CALL chkxer( 'DGTCON', infot, nout, lerr, ok )
176  infot = 2
177  CALL dgtcon( 'I', -1, c, d, e, f, ip, anorm, rcond, w, iw,
178  $ info )
179  CALL chkxer( 'DGTCON', infot, nout, lerr, ok )
180  infot = 8
181  CALL dgtcon( 'I', 0, c, d, e, f, ip, -anorm, rcond, w, iw,
182  $ info )
183  CALL chkxer( 'DGTCON', infot, nout, lerr, ok )
184 *
185  ELSE IF( lsamen( 2, c2, 'PT' ) ) THEN
186 *
187 * Test error exits for the positive definite tridiagonal
188 * routines.
189 *
190 * DPTTRF
191 *
192  srnamt = 'DPTTRF'
193  infot = 1
194  CALL dpttrf( -1, d, e, info )
195  CALL chkxer( 'DPTTRF', infot, nout, lerr, ok )
196 *
197 * DPTTRS
198 *
199  srnamt = 'DPTTRS'
200  infot = 1
201  CALL dpttrs( -1, 0, d, e, x, 1, info )
202  CALL chkxer( 'DPTTRS', infot, nout, lerr, ok )
203  infot = 2
204  CALL dpttrs( 0, -1, d, e, x, 1, info )
205  CALL chkxer( 'DPTTRS', infot, nout, lerr, ok )
206  infot = 6
207  CALL dpttrs( 2, 1, d, e, x, 1, info )
208  CALL chkxer( 'DPTTRS', infot, nout, lerr, ok )
209 *
210 * DPTRFS
211 *
212  srnamt = 'DPTRFS'
213  infot = 1
214  CALL dptrfs( -1, 0, d, e, df, ef, b, 1, x, 1, r1, r2, w, info )
215  CALL chkxer( 'DPTRFS', infot, nout, lerr, ok )
216  infot = 2
217  CALL dptrfs( 0, -1, d, e, df, ef, b, 1, x, 1, r1, r2, w, info )
218  CALL chkxer( 'DPTRFS', infot, nout, lerr, ok )
219  infot = 8
220  CALL dptrfs( 2, 1, d, e, df, ef, b, 1, x, 2, r1, r2, w, info )
221  CALL chkxer( 'DPTRFS', infot, nout, lerr, ok )
222  infot = 10
223  CALL dptrfs( 2, 1, d, e, df, ef, b, 2, x, 1, r1, r2, w, info )
224  CALL chkxer( 'DPTRFS', infot, nout, lerr, ok )
225 *
226 * DPTCON
227 *
228  srnamt = 'DPTCON'
229  infot = 1
230  CALL dptcon( -1, d, e, anorm, rcond, w, info )
231  CALL chkxer( 'DPTCON', infot, nout, lerr, ok )
232  infot = 4
233  CALL dptcon( 0, d, e, -anorm, rcond, w, info )
234  CALL chkxer( 'DPTCON', infot, nout, lerr, ok )
235  END IF
236 *
237 * Print a summary line.
238 *
239  CALL alaesm( path, ok, nout )
240 *
241  return
242 *
243 * End of DERRGT
244 *
245  END