OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
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,
88 $ sptcon, sptrfs, spttrf, spttrs
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
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3196
spttrf
subroutine spttrf(n, d, e, info)
SPTTRF
Definition spttrf.f:91
alaesm
subroutine alaesm(path, ok, nout)
ALAESM
Definition alaesm.f:63
sgtrfs
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
sgtcon
subroutine sgtcon(norm, n, dl, d, du, du2, ipiv, anorm, rcond, work, iwork, info)
SGTCON
Definition sgtcon.f:146
sgttrf
subroutine sgttrf(n, dl, d, du, du2, ipiv, info)
SGTTRF
Definition sgttrf.f:124
sgttrs
subroutine sgttrs(trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb, info)
SGTTRS
Definition sgttrs.f:138
sptcon
subroutine sptcon(n, d, e, anorm, rcond, work, info)
SPTCON
Definition sptcon.f:118
sptrfs
subroutine sptrfs(n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr, berr, work, info)
SPTRFS
Definition sptrfs.f:163
spttrs
subroutine spttrs(n, nrhs, d, e, b, ldb, info)
SPTTRS
Definition spttrs.f:109
serrgt
subroutine serrgt(path, nunit)
SERRGT
Definition serrgt.f:55