LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
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 *> \ingroup single_lin
52 *
53 * =====================================================================
54  SUBROUTINE serrgt( PATH, NUNIT )
55 *
56 * -- LAPACK test routine --
57 * -- LAPACK is a software package provided by Univ. of Tennessee, --
58 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59 *
60 * .. Scalar Arguments ..
61  CHARACTER*3 PATH
62  INTEGER NUNIT
63 * ..
64 *
65 * =====================================================================
66 *
67 * .. Parameters ..
68  INTEGER NMAX
69  parameter( nmax = 2 )
70 * ..
71 * .. Local Scalars ..
72  CHARACTER*2 C2
73  INTEGER INFO
74  REAL ANORM, RCOND
75 * ..
76 * .. Local Arrays ..
77  INTEGER IP( NMAX ), IW( NMAX )
78  REAL B( NMAX ), C( NMAX ), CF( NMAX ), D( NMAX ),
79  $ DF( NMAX ), E( NMAX ), EF( NMAX ), F( NMAX ),
80  $ R1( NMAX ), R2( NMAX ), W( NMAX ), X( NMAX )
81 * ..
82 * .. External Functions ..
83  LOGICAL LSAMEN
84  EXTERNAL lsamen
85 * ..
86 * .. External Subroutines ..
87  EXTERNAL alaesm, chkxer, sgtcon, sgtrfs, sgttrf, sgttrs,
89 * ..
90 * .. Scalars in Common ..
91  LOGICAL LERR, OK
92  CHARACTER*32 SRNAMT
93  INTEGER INFOT, NOUT
94 * ..
95 * .. Common blocks ..
96  COMMON / infoc / infot, nout, ok, lerr
97  COMMON / srnamc / srnamt
98 * ..
99 * .. Executable Statements ..
100 *
101  nout = nunit
102  WRITE( nout, fmt = * )
103  c2 = path( 2: 3 )
104  d( 1 ) = 1.
105  d( 2 ) = 2.
106  df( 1 ) = 1.
107  df( 2 ) = 2.
108  e( 1 ) = 3.
109  e( 2 ) = 4.
110  ef( 1 ) = 3.
111  ef( 2 ) = 4.
112  anorm = 1.0
113  ok = .true.
114 *
115  IF( lsamen( 2, c2, 'GT' ) ) THEN
116 *
117 * Test error exits for the general tridiagonal routines.
118 *
119 * SGTTRF
120 *
121  srnamt = 'SGTTRF'
122  infot = 1
123  CALL sgttrf( -1, c, d, e, f, ip, info )
124  CALL chkxer( 'SGTTRF', infot, nout, lerr, ok )
125 *
126 * SGTTRS
127 *
128  srnamt = 'SGTTRS'
129  infot = 1
130  CALL sgttrs( '/', 0, 0, c, d, e, f, ip, x, 1, info )
131  CALL chkxer( 'SGTTRS', infot, nout, lerr, ok )
132  infot = 2
133  CALL sgttrs( 'N', -1, 0, c, d, e, f, ip, x, 1, info )
134  CALL chkxer( 'SGTTRS', infot, nout, lerr, ok )
135  infot = 3
136  CALL sgttrs( 'N', 0, -1, c, d, e, f, ip, x, 1, info )
137  CALL chkxer( 'SGTTRS', infot, nout, lerr, ok )
138  infot = 10
139  CALL sgttrs( 'N', 2, 1, c, d, e, f, ip, x, 1, info )
140  CALL chkxer( 'SGTTRS', infot, nout, lerr, ok )
141 *
142 * SGTRFS
143 *
144  srnamt = 'SGTRFS'
145  infot = 1
146  CALL sgtrfs( '/', 0, 0, c, d, e, cf, df, ef, f, ip, b, 1, x, 1,
147  $ r1, r2, w, iw, info )
148  CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
149  infot = 2
150  CALL sgtrfs( 'N', -1, 0, c, d, e, cf, df, ef, f, ip, b, 1, x,
151  $ 1, r1, r2, w, iw, info )
152  CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
153  infot = 3
154  CALL sgtrfs( 'N', 0, -1, c, d, e, cf, df, ef, f, ip, b, 1, x,
155  $ 1, r1, r2, w, iw, info )
156  CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
157  infot = 13
158  CALL sgtrfs( 'N', 2, 1, c, d, e, cf, df, ef, f, ip, b, 1, x, 2,
159  $ r1, r2, w, iw, info )
160  CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
161  infot = 15
162  CALL sgtrfs( 'N', 2, 1, c, d, e, cf, df, ef, f, ip, b, 2, x, 1,
163  $ r1, r2, w, iw, info )
164  CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
165 *
166 * SGTCON
167 *
168  srnamt = 'SGTCON'
169  infot = 1
170  CALL sgtcon( '/', 0, c, d, e, f, ip, anorm, rcond, w, iw,
171  $ info )
172  CALL chkxer( 'SGTCON', infot, nout, lerr, ok )
173  infot = 2
174  CALL sgtcon( 'I', -1, c, d, e, f, ip, anorm, rcond, w, iw,
175  $ info )
176  CALL chkxer( 'SGTCON', infot, nout, lerr, ok )
177  infot = 8
178  CALL sgtcon( 'I', 0, c, d, e, f, ip, -anorm, rcond, w, iw,
179  $ info )
180  CALL chkxer( 'SGTCON', infot, nout, lerr, ok )
181 *
182  ELSE IF( lsamen( 2, c2, 'PT' ) ) THEN
183 *
184 * Test error exits for the positive definite tridiagonal
185 * routines.
186 *
187 * SPTTRF
188 *
189  srnamt = 'SPTTRF'
190  infot = 1
191  CALL spttrf( -1, d, e, info )
192  CALL chkxer( 'SPTTRF', infot, nout, lerr, ok )
193 *
194 * SPTTRS
195 *
196  srnamt = 'SPTTRS'
197  infot = 1
198  CALL spttrs( -1, 0, d, e, x, 1, info )
199  CALL chkxer( 'SPTTRS', infot, nout, lerr, ok )
200  infot = 2
201  CALL spttrs( 0, -1, d, e, x, 1, info )
202  CALL chkxer( 'SPTTRS', infot, nout, lerr, ok )
203  infot = 6
204  CALL spttrs( 2, 1, d, e, x, 1, info )
205  CALL chkxer( 'SPTTRS', infot, nout, lerr, ok )
206 *
207 * SPTRFS
208 *
209  srnamt = 'SPTRFS'
210  infot = 1
211  CALL sptrfs( -1, 0, d, e, df, ef, b, 1, x, 1, r1, r2, w, info )
212  CALL chkxer( 'SPTRFS', infot, nout, lerr, ok )
213  infot = 2
214  CALL sptrfs( 0, -1, d, e, df, ef, b, 1, x, 1, r1, r2, w, info )
215  CALL chkxer( 'SPTRFS', infot, nout, lerr, ok )
216  infot = 8
217  CALL sptrfs( 2, 1, d, e, df, ef, b, 1, x, 2, r1, r2, w, info )
218  CALL chkxer( 'SPTRFS', infot, nout, lerr, ok )
219  infot = 10
220  CALL sptrfs( 2, 1, d, e, df, ef, b, 2, x, 1, r1, r2, w, info )
221  CALL chkxer( 'SPTRFS', infot, nout, lerr, ok )
222 *
223 * SPTCON
224 *
225  srnamt = 'SPTCON'
226  infot = 1
227  CALL sptcon( -1, d, e, anorm, rcond, w, info )
228  CALL chkxer( 'SPTCON', infot, nout, lerr, ok )
229  infot = 4
230  CALL sptcon( 0, d, e, -anorm, rcond, w, info )
231  CALL chkxer( 'SPTCON', infot, nout, lerr, ok )
232  END IF
233 *
234 * Print a summary line.
235 *
236  CALL alaesm( path, ok, nout )
237 *
238  RETURN
239 *
240 * End of SERRGT
241 *
242  END
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
Definition: cblat2.f:3196
subroutine alaesm(PATH, OK, NOUT)
ALAESM
Definition: alaesm.f:63
subroutine spttrf(N, D, E, INFO)
SPTTRF
Definition: spttrf.f:91
subroutine sgttrf(N, DL, D, DU, DU2, IPIV, INFO)
SGTTRF
Definition: sgttrf.f:124
subroutine sgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
SGTTRS
Definition: sgttrs.f:138
subroutine sgtcon(NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
SGTCON
Definition: sgtcon.f:146
subroutine sgtrfs(TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SGTRFS
Definition: sgtrfs.f:209
subroutine sptrfs(N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO)
SPTRFS
Definition: sptrfs.f:163
subroutine sptcon(N, D, E, ANORM, RCOND, WORK, INFO)
SPTCON
Definition: sptcon.f:118
subroutine spttrs(N, NRHS, D, E, B, LDB, INFO)
SPTTRS
Definition: spttrs.f:109
subroutine serrgt(PATH, NUNIT)
SERRGT
Definition: serrgt.f:55