LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ serrec()

subroutine serrec ( character*3  PATH,
integer  NUNIT 
)

SERREC

Purpose:
 SERREC tests the error exits for the routines for eigen- condition
 estimation for REAL matrices:
    STRSYL, STREXC, STRSNA and STRSEN.
Parameters
[in]PATH
          PATH is CHARACTER*3
          The LAPACK path name for the routines to be tested.
[in]NUNIT
          NUNIT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 55 of file serrec.f.

56 *
57 * -- LAPACK test routine --
58 * -- LAPACK is a software package provided by Univ. of Tennessee, --
59 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
60 *
61 * .. Scalar Arguments ..
62  CHARACTER*3 PATH
63  INTEGER NUNIT
64 * ..
65 *
66 * =====================================================================
67 *
68 * .. Parameters ..
69  INTEGER NMAX
70  REAL ONE, ZERO
71  parameter( nmax = 4, one = 1.0e0, zero = 0.0e0 )
72 * ..
73 * .. Local Scalars ..
74  INTEGER I, IFST, ILST, INFO, J, M, NT
75  REAL SCALE
76 * ..
77 * .. Local Arrays ..
78  LOGICAL SEL( NMAX )
79  INTEGER IWORK( NMAX )
80  REAL A( NMAX, NMAX ), B( NMAX, NMAX ),
81  $ C( NMAX, NMAX ), S( NMAX ), SEP( NMAX ),
82  $ WI( NMAX ), WORK( NMAX ), WR( NMAX )
83 * ..
84 * .. External Subroutines ..
85  EXTERNAL chkxer, strexc, strsen, strsna, strsyl
86 * ..
87 * .. Scalars in Common ..
88  LOGICAL LERR, OK
89  CHARACTER*32 SRNAMT
90  INTEGER INFOT, NOUT
91 * ..
92 * .. Common blocks ..
93  COMMON / infoc / infot, nout, ok, lerr
94  COMMON / srnamc / srnamt
95 * ..
96 * .. Executable Statements ..
97 *
98  nout = nunit
99  ok = .true.
100  nt = 0
101 *
102 * Initialize A, B and SEL
103 *
104  DO 20 j = 1, nmax
105  DO 10 i = 1, nmax
106  a( i, j ) = zero
107  b( i, j ) = zero
108  10 CONTINUE
109  20 CONTINUE
110  DO 30 i = 1, nmax
111  a( i, i ) = one
112  sel( i ) = .true.
113  30 CONTINUE
114 *
115 * Test STRSYL
116 *
117  srnamt = 'STRSYL'
118  infot = 1
119  CALL strsyl( 'X', 'N', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
120  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
121  infot = 2
122  CALL strsyl( 'N', 'X', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
123  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
124  infot = 3
125  CALL strsyl( 'N', 'N', 0, 0, 0, a, 1, b, 1, c, 1, scale, info )
126  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
127  infot = 4
128  CALL strsyl( 'N', 'N', 1, -1, 0, a, 1, b, 1, c, 1, scale, info )
129  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
130  infot = 5
131  CALL strsyl( 'N', 'N', 1, 0, -1, a, 1, b, 1, c, 1, scale, info )
132  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
133  infot = 7
134  CALL strsyl( 'N', 'N', 1, 2, 0, a, 1, b, 1, c, 2, scale, info )
135  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
136  infot = 9
137  CALL strsyl( 'N', 'N', 1, 0, 2, a, 1, b, 1, c, 1, scale, info )
138  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
139  infot = 11
140  CALL strsyl( 'N', 'N', 1, 2, 0, a, 2, b, 1, c, 1, scale, info )
141  CALL chkxer( 'STRSYL', infot, nout, lerr, ok )
142  nt = nt + 8
143 *
144 * Test STREXC
145 *
146  srnamt = 'STREXC'
147  ifst = 1
148  ilst = 1
149  infot = 1
150  CALL strexc( 'X', 1, a, 1, b, 1, ifst, ilst, work, info )
151  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
152  infot = 2
153  CALL strexc( 'N', -1, a, 1, b, 1, ifst, ilst, work, info )
154  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
155  infot = 4
156  ilst = 2
157  CALL strexc( 'N', 2, a, 1, b, 1, ifst, ilst, work, info )
158  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
159  infot = 6
160  CALL strexc( 'V', 2, a, 2, b, 1, ifst, ilst, work, info )
161  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
162  infot = 7
163  ifst = 0
164  ilst = 1
165  CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
166  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
167  infot = 7
168  ifst = 2
169  CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
170  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
171  infot = 8
172  ifst = 1
173  ilst = 0
174  CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
175  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
176  infot = 8
177  ilst = 2
178  CALL strexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
179  CALL chkxer( 'STREXC', infot, nout, lerr, ok )
180  nt = nt + 8
181 *
182 * Test STRSNA
183 *
184  srnamt = 'STRSNA'
185  infot = 1
186  CALL strsna( 'X', 'A', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
187  $ work, 1, iwork, info )
188  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
189  infot = 2
190  CALL strsna( 'B', 'X', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
191  $ work, 1, iwork, info )
192  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
193  infot = 4
194  CALL strsna( 'B', 'A', sel, -1, a, 1, b, 1, c, 1, s, sep, 1, m,
195  $ work, 1, iwork, info )
196  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
197  infot = 6
198  CALL strsna( 'V', 'A', sel, 2, a, 1, b, 1, c, 1, s, sep, 2, m,
199  $ work, 2, iwork, info )
200  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
201  infot = 8
202  CALL strsna( 'B', 'A', sel, 2, a, 2, b, 1, c, 2, s, sep, 2, m,
203  $ work, 2, iwork, info )
204  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
205  infot = 10
206  CALL strsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 1, s, sep, 2, m,
207  $ work, 2, iwork, info )
208  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
209  infot = 13
210  CALL strsna( 'B', 'A', sel, 1, a, 1, b, 1, c, 1, s, sep, 0, m,
211  $ work, 1, iwork, info )
212  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
213  infot = 13
214  CALL strsna( 'B', 'S', sel, 2, a, 2, b, 2, c, 2, s, sep, 1, m,
215  $ work, 2, iwork, info )
216  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
217  infot = 16
218  CALL strsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 2, s, sep, 2, m,
219  $ work, 1, iwork, info )
220  CALL chkxer( 'STRSNA', infot, nout, lerr, ok )
221  nt = nt + 9
222 *
223 * Test STRSEN
224 *
225  sel( 1 ) = .false.
226  srnamt = 'STRSEN'
227  infot = 1
228  CALL strsen( 'X', 'N', sel, 0, a, 1, b, 1, wr, wi, m, s( 1 ),
229  $ sep( 1 ), work, 1, iwork, 1, info )
230  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
231  infot = 2
232  CALL strsen( 'N', 'X', sel, 0, a, 1, b, 1, wr, wi, m, s( 1 ),
233  $ sep( 1 ), work, 1, iwork, 1, info )
234  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
235  infot = 4
236  CALL strsen( 'N', 'N', sel, -1, a, 1, b, 1, wr, wi, m, s( 1 ),
237  $ sep( 1 ), work, 1, iwork, 1, info )
238  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
239  infot = 6
240  CALL strsen( 'N', 'N', sel, 2, a, 1, b, 1, wr, wi, m, s( 1 ),
241  $ sep( 1 ), work, 2, iwork, 1, info )
242  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
243  infot = 8
244  CALL strsen( 'N', 'V', sel, 2, a, 2, b, 1, wr, wi, m, s( 1 ),
245  $ sep( 1 ), work, 1, iwork, 1, info )
246  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
247  infot = 15
248  CALL strsen( 'N', 'V', sel, 2, a, 2, b, 2, wr, wi, m, s( 1 ),
249  $ sep( 1 ), work, 0, iwork, 1, info )
250  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
251  infot = 15
252  CALL strsen( 'E', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
253  $ sep( 1 ), work, 1, iwork, 1, info )
254  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
255  infot = 15
256  CALL strsen( 'V', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
257  $ sep( 1 ), work, 3, iwork, 2, info )
258  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
259  infot = 17
260  CALL strsen( 'E', 'V', sel, 2, a, 2, b, 2, wr, wi, m, s( 1 ),
261  $ sep( 1 ), work, 1, iwork, 0, info )
262  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
263  infot = 17
264  CALL strsen( 'V', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
265  $ sep( 1 ), work, 4, iwork, 1, info )
266  CALL chkxer( 'STRSEN', infot, nout, lerr, ok )
267  nt = nt + 10
268 *
269 * Print a summary line.
270 *
271  IF( ok ) THEN
272  WRITE( nout, fmt = 9999 )path, nt
273  ELSE
274  WRITE( nout, fmt = 9998 )path
275  END IF
276 *
277  RETURN
278  9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits (',
279  $ i3, ' tests done)' )
280  9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ex',
281  $ 'its ***' )
282 *
283 * End of SERREC
284 *
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
Definition: cblat2.f:3196
subroutine strexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO)
STREXC
Definition: strexc.f:148
subroutine strsna(JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO)
STRSNA
Definition: strsna.f:265
subroutine strsen(JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO)
STRSEN
Definition: strsen.f:314
subroutine strsyl(TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO)
STRSYL
Definition: strsyl.f:164
Here is the call graph for this function:
Here is the caller graph for this function: