LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cerrgt.f
Go to the documentation of this file.
1 *> \brief \b CERRGT
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 CERRGT( 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 *> CERRGT tests the error exits for the COMPLEX 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 complex_lin
54 *
55 * =====================================================================
56  SUBROUTINE cerrgt( 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 i, info
77  REAL anorm, rcond
78 * ..
79 * .. Local Arrays ..
80  INTEGER ip( nmax )
81  REAL d( nmax ), df( nmax ), r1( nmax ), r2( nmax ),
82  $ rw( nmax )
83  COMPLEX b( nmax ), dl( nmax ), dlf( nmax ), du( nmax ),
84  $ du2( nmax ), duf( nmax ), e( nmax ),
85  $ ef( nmax ), w( nmax ), x( nmax )
86 * ..
87 * .. External Functions ..
88  LOGICAL lsamen
89  EXTERNAL lsamen
90 * ..
91 * .. External Subroutines ..
92  EXTERNAL alaesm, cgtcon, cgtrfs, cgttrf, cgttrs, chkxer,
93  $ cptcon, cptrfs, cpttrf, cpttrs
94 * ..
95 * .. Scalars in Common ..
96  LOGICAL lerr, ok
97  CHARACTER*32 srnamt
98  INTEGER infot, nout
99 * ..
100 * .. Common blocks ..
101  common / infoc / infot, nout, ok, lerr
102  common / srnamc / srnamt
103 * ..
104 * .. Executable Statements ..
105 *
106  nout = nunit
107  WRITE( nout, fmt = * )
108  c2 = path( 2: 3 )
109  DO 10 i = 1, nmax
110  d( i ) = 1.
111  e( i ) = 2.
112  dl( i ) = 3.
113  du( i ) = 4.
114  10 continue
115  anorm = 1.0
116  ok = .true.
117 *
118  IF( lsamen( 2, c2, 'GT' ) ) THEN
119 *
120 * Test error exits for the general tridiagonal routines.
121 *
122 * CGTTRF
123 *
124  srnamt = 'CGTTRF'
125  infot = 1
126  CALL cgttrf( -1, dl, e, du, du2, ip, info )
127  CALL chkxer( 'CGTTRF', infot, nout, lerr, ok )
128 *
129 * CGTTRS
130 *
131  srnamt = 'CGTTRS'
132  infot = 1
133  CALL cgttrs( '/', 0, 0, dl, e, du, du2, ip, x, 1, info )
134  CALL chkxer( 'CGTTRS', infot, nout, lerr, ok )
135  infot = 2
136  CALL cgttrs( 'N', -1, 0, dl, e, du, du2, ip, x, 1, info )
137  CALL chkxer( 'CGTTRS', infot, nout, lerr, ok )
138  infot = 3
139  CALL cgttrs( 'N', 0, -1, dl, e, du, du2, ip, x, 1, info )
140  CALL chkxer( 'CGTTRS', infot, nout, lerr, ok )
141  infot = 10
142  CALL cgttrs( 'N', 2, 1, dl, e, du, du2, ip, x, 1, info )
143  CALL chkxer( 'CGTTRS', infot, nout, lerr, ok )
144 *
145 * CGTRFS
146 *
147  srnamt = 'CGTRFS'
148  infot = 1
149  CALL cgtrfs( '/', 0, 0, dl, e, du, dlf, ef, duf, du2, ip, b, 1,
150  $ x, 1, r1, r2, w, rw, info )
151  CALL chkxer( 'CGTRFS', infot, nout, lerr, ok )
152  infot = 2
153  CALL cgtrfs( 'N', -1, 0, dl, e, du, dlf, ef, duf, du2, ip, b,
154  $ 1, x, 1, r1, r2, w, rw, info )
155  CALL chkxer( 'CGTRFS', infot, nout, lerr, ok )
156  infot = 3
157  CALL cgtrfs( 'N', 0, -1, dl, e, du, dlf, ef, duf, du2, ip, b,
158  $ 1, x, 1, r1, r2, w, rw, info )
159  CALL chkxer( 'CGTRFS', infot, nout, lerr, ok )
160  infot = 13
161  CALL cgtrfs( 'N', 2, 1, dl, e, du, dlf, ef, duf, du2, ip, b, 1,
162  $ x, 2, r1, r2, w, rw, info )
163  CALL chkxer( 'CGTRFS', infot, nout, lerr, ok )
164  infot = 15
165  CALL cgtrfs( 'N', 2, 1, dl, e, du, dlf, ef, duf, du2, ip, b, 2,
166  $ x, 1, r1, r2, w, rw, info )
167  CALL chkxer( 'CGTRFS', infot, nout, lerr, ok )
168 *
169 * CGTCON
170 *
171  srnamt = 'CGTCON'
172  infot = 1
173  CALL cgtcon( '/', 0, dl, e, du, du2, ip, anorm, rcond, w,
174  $ info )
175  CALL chkxer( 'CGTCON', infot, nout, lerr, ok )
176  infot = 2
177  CALL cgtcon( 'I', -1, dl, e, du, du2, ip, anorm, rcond, w,
178  $ info )
179  CALL chkxer( 'CGTCON', infot, nout, lerr, ok )
180  infot = 8
181  CALL cgtcon( 'I', 0, dl, e, du, du2, ip, -anorm, rcond, w,
182  $ info )
183  CALL chkxer( 'CGTCON', 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 * CPTTRF
191 *
192  srnamt = 'CPTTRF'
193  infot = 1
194  CALL cpttrf( -1, d, e, info )
195  CALL chkxer( 'CPTTRF', infot, nout, lerr, ok )
196 *
197 * CPTTRS
198 *
199  srnamt = 'CPTTRS'
200  infot = 1
201  CALL cpttrs( '/', 1, 0, d, e, x, 1, info )
202  CALL chkxer( 'CPTTRS', infot, nout, lerr, ok )
203  infot = 2
204  CALL cpttrs( 'U', -1, 0, d, e, x, 1, info )
205  CALL chkxer( 'CPTTRS', infot, nout, lerr, ok )
206  infot = 3
207  CALL cpttrs( 'U', 0, -1, d, e, x, 1, info )
208  CALL chkxer( 'CPTTRS', infot, nout, lerr, ok )
209  infot = 7
210  CALL cpttrs( 'U', 2, 1, d, e, x, 1, info )
211  CALL chkxer( 'CPTTRS', infot, nout, lerr, ok )
212 *
213 * CPTRFS
214 *
215  srnamt = 'CPTRFS'
216  infot = 1
217  CALL cptrfs( '/', 1, 0, d, e, df, ef, b, 1, x, 1, r1, r2, w,
218  $ rw, info )
219  CALL chkxer( 'CPTRFS', infot, nout, lerr, ok )
220  infot = 2
221  CALL cptrfs( 'U', -1, 0, d, e, df, ef, b, 1, x, 1, r1, r2, w,
222  $ rw, info )
223  CALL chkxer( 'CPTRFS', infot, nout, lerr, ok )
224  infot = 3
225  CALL cptrfs( 'U', 0, -1, d, e, df, ef, b, 1, x, 1, r1, r2, w,
226  $ rw, info )
227  CALL chkxer( 'CPTRFS', infot, nout, lerr, ok )
228  infot = 9
229  CALL cptrfs( 'U', 2, 1, d, e, df, ef, b, 1, x, 2, r1, r2, w,
230  $ rw, info )
231  CALL chkxer( 'CPTRFS', infot, nout, lerr, ok )
232  infot = 11
233  CALL cptrfs( 'U', 2, 1, d, e, df, ef, b, 2, x, 1, r1, r2, w,
234  $ rw, info )
235  CALL chkxer( 'CPTRFS', infot, nout, lerr, ok )
236 *
237 * CPTCON
238 *
239  srnamt = 'CPTCON'
240  infot = 1
241  CALL cptcon( -1, d, e, anorm, rcond, rw, info )
242  CALL chkxer( 'CPTCON', infot, nout, lerr, ok )
243  infot = 4
244  CALL cptcon( 0, d, e, -anorm, rcond, rw, info )
245  CALL chkxer( 'CPTCON', infot, nout, lerr, ok )
246  END IF
247 *
248 * Print a summary line.
249 *
250  CALL alaesm( path, ok, nout )
251 *
252  return
253 *
254 * End of CERRGT
255 *
256  END