LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
serrgt.f
Go to the documentation of this file.
1 *> \brief \b SERRGT
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 SERRGT( 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 *> SERRGT tests the error exits for the REAL 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 single_lin
54 *
55 * =====================================================================
56  SUBROUTINE serrgt( 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  REAL anorm, rcond
78 * ..
79 * .. Local Arrays ..
80  INTEGER ip( nmax ), iw( nmax )
81  REAL 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, sgtcon, sgtrfs, sgttrf, sgttrs,
91  $ sptcon, sptrfs, spttrf, spttrs
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.
108  d( 2 ) = 2.
109  df( 1 ) = 1.
110  df( 2 ) = 2.
111  e( 1 ) = 3.
112  e( 2 ) = 4.
113  ef( 1 ) = 3.
114  ef( 2 ) = 4.
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 * SGTTRF
123 *
124  srnamt = 'SGTTRF'
125  infot = 1
126  CALL sgttrf( -1, c, d, e, f, ip, info )
127  CALL chkxer( 'SGTTRF', infot, nout, lerr, ok )
128 *
129 * SGTTRS
130 *
131  srnamt = 'SGTTRS'
132  infot = 1
133  CALL sgttrs( '/', 0, 0, c, d, e, f, ip, x, 1, info )
134  CALL chkxer( 'SGTTRS', infot, nout, lerr, ok )
135  infot = 2
136  CALL sgttrs( 'N', -1, 0, c, d, e, f, ip, x, 1, info )
137  CALL chkxer( 'SGTTRS', infot, nout, lerr, ok )
138  infot = 3
139  CALL sgttrs( 'N', 0, -1, c, d, e, f, ip, x, 1, info )
140  CALL chkxer( 'SGTTRS', infot, nout, lerr, ok )
141  infot = 10
142  CALL sgttrs( 'N', 2, 1, c, d, e, f, ip, x, 1, info )
143  CALL chkxer( 'SGTTRS', infot, nout, lerr, ok )
144 *
145 * SGTRFS
146 *
147  srnamt = 'SGTRFS'
148  infot = 1
149  CALL sgtrfs( '/', 0, 0, c, d, e, cf, df, ef, f, ip, b, 1, x, 1,
150  $ r1, r2, w, iw, info )
151  CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
152  infot = 2
153  CALL sgtrfs( 'N', -1, 0, c, d, e, cf, df, ef, f, ip, b, 1, x,
154  $ 1, r1, r2, w, iw, info )
155  CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
156  infot = 3
157  CALL sgtrfs( 'N', 0, -1, c, d, e, cf, df, ef, f, ip, b, 1, x,
158  $ 1, r1, r2, w, iw, info )
159  CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
160  infot = 13
161  CALL sgtrfs( 'N', 2, 1, c, d, e, cf, df, ef, f, ip, b, 1, x, 2,
162  $ r1, r2, w, iw, info )
163  CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
164  infot = 15
165  CALL sgtrfs( 'N', 2, 1, c, d, e, cf, df, ef, f, ip, b, 2, x, 1,
166  $ r1, r2, w, iw, info )
167  CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
168 *
169 * SGTCON
170 *
171  srnamt = 'SGTCON'
172  infot = 1
173  CALL sgtcon( '/', 0, c, d, e, f, ip, anorm, rcond, w, iw,
174  $ info )
175  CALL chkxer( 'SGTCON', infot, nout, lerr, ok )
176  infot = 2
177  CALL sgtcon( 'I', -1, c, d, e, f, ip, anorm, rcond, w, iw,
178  $ info )
179  CALL chkxer( 'SGTCON', infot, nout, lerr, ok )
180  infot = 8
181  CALL sgtcon( 'I', 0, c, d, e, f, ip, -anorm, rcond, w, iw,
182  $ info )
183  CALL chkxer( 'SGTCON', 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 * SPTTRF
191 *
192  srnamt = 'SPTTRF'
193  infot = 1
194  CALL spttrf( -1, d, e, info )
195  CALL chkxer( 'SPTTRF', infot, nout, lerr, ok )
196 *
197 * SPTTRS
198 *
199  srnamt = 'SPTTRS'
200  infot = 1
201  CALL spttrs( -1, 0, d, e, x, 1, info )
202  CALL chkxer( 'SPTTRS', infot, nout, lerr, ok )
203  infot = 2
204  CALL spttrs( 0, -1, d, e, x, 1, info )
205  CALL chkxer( 'SPTTRS', infot, nout, lerr, ok )
206  infot = 6
207  CALL spttrs( 2, 1, d, e, x, 1, info )
208  CALL chkxer( 'SPTTRS', infot, nout, lerr, ok )
209 *
210 * SPTRFS
211 *
212  srnamt = 'SPTRFS'
213  infot = 1
214  CALL sptrfs( -1, 0, d, e, df, ef, b, 1, x, 1, r1, r2, w, info )
215  CALL chkxer( 'SPTRFS', infot, nout, lerr, ok )
216  infot = 2
217  CALL sptrfs( 0, -1, d, e, df, ef, b, 1, x, 1, r1, r2, w, info )
218  CALL chkxer( 'SPTRFS', infot, nout, lerr, ok )
219  infot = 8
220  CALL sptrfs( 2, 1, d, e, df, ef, b, 1, x, 2, r1, r2, w, info )
221  CALL chkxer( 'SPTRFS', infot, nout, lerr, ok )
222  infot = 10
223  CALL sptrfs( 2, 1, d, e, df, ef, b, 2, x, 1, r1, r2, w, info )
224  CALL chkxer( 'SPTRFS', infot, nout, lerr, ok )
225 *
226 * SPTCON
227 *
228  srnamt = 'SPTCON'
229  infot = 1
230  CALL sptcon( -1, d, e, anorm, rcond, w, info )
231  CALL chkxer( 'SPTCON', infot, nout, lerr, ok )
232  infot = 4
233  CALL sptcon( 0, d, e, -anorm, rcond, w, info )
234  CALL chkxer( 'SPTCON', 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 SERRGT
244 *
245  END