1 SUBROUTINE DDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
2 $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
3 $ NOUT )
4 *
5 * -- LAPACK test routine (version 3.1) --
6 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
7 * November 2006
8 *
9 * .. Scalar Arguments ..
10 LOGICAL TSTERR
11 INTEGER NMAX, NN, NOUT, NRHS
12 DOUBLE PRECISION THRESH
13 * ..
14 * .. Array Arguments ..
15 LOGICAL DOTYPE( * )
16 INTEGER IWORK( * ), NVAL( * )
17 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
18 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
19 * ..
20 *
21 * Purpose
22 * =======
23 *
24 * DDRVSP tests the driver routines DSPSV and -SVX.
25 *
26 * Arguments
27 * =========
28 *
29 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
30 * The matrix types to be used for testing. Matrices of type j
31 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
32 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
33 *
34 * NN (input) INTEGER
35 * The number of values of N contained in the vector NVAL.
36 *
37 * NVAL (input) INTEGER array, dimension (NN)
38 * The values of the matrix dimension N.
39 *
40 * NRHS (input) INTEGER
41 * The number of right hand side vectors to be generated for
42 * each linear system.
43 *
44 * THRESH (input) DOUBLE PRECISION
45 * The threshold value for the test ratios. A result is
46 * included in the output file if RESULT >= THRESH. To have
47 * every test ratio printed, use THRESH = 0.
48 *
49 * TSTERR (input) LOGICAL
50 * Flag that indicates whether error exits are to be tested.
51 *
52 * NMAX (input) INTEGER
53 * The maximum value permitted for N, used in dimensioning the
54 * work arrays.
55 *
56 * A (workspace) DOUBLE PRECISION array, dimension
57 * (NMAX*(NMAX+1)/2)
58 *
59 * AFAC (workspace) DOUBLE PRECISION array, dimension
60 * (NMAX*(NMAX+1)/2)
61 *
62 * AINV (workspace) DOUBLE PRECISION array, dimension
63 * (NMAX*(NMAX+1)/2)
64 *
65 * B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
66 *
67 * X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
68 *
69 * XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
70 *
71 * WORK (workspace) DOUBLE PRECISION array, dimension
72 * (NMAX*max(2,NRHS))
73 *
74 * RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
75 *
76 * IWORK (workspace) INTEGER array, dimension (2*NMAX)
77 *
78 * NOUT (input) INTEGER
79 * The unit number for output.
80 *
81 * =====================================================================
82 *
83 * .. Parameters ..
84 DOUBLE PRECISION ONE, ZERO
85 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
86 INTEGER NTYPES, NTESTS
87 PARAMETER ( NTYPES = 10, NTESTS = 6 )
88 INTEGER NFACT
89 PARAMETER ( NFACT = 2 )
90 * ..
91 * .. Local Scalars ..
92 LOGICAL ZEROT
93 CHARACTER DIST, FACT, PACKIT, TYPE, UPLO, XTYPE
94 CHARACTER*3 PATH
95 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
96 $ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N,
97 $ NERRS, NFAIL, NIMAT, NPP, NRUN, NT
98 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
99 * ..
100 * .. Local Arrays ..
101 CHARACTER FACTS( NFACT )
102 INTEGER ISEED( 4 ), ISEEDY( 4 )
103 DOUBLE PRECISION RESULT( NTESTS )
104 * ..
105 * .. External Functions ..
106 DOUBLE PRECISION DGET06, DLANSP
107 EXTERNAL DGET06, DLANSP
108 * ..
109 * .. External Subroutines ..
110 EXTERNAL ALADHD, ALAERH, ALASVM, DCOPY, DERRVX, DGET04,
111 $ DLACPY, DLARHS, DLASET, DLATB4, DLATMS, DPPT02,
112 $ DPPT05, DSPSV, DSPSVX, DSPT01, DSPTRF, DSPTRI
113 * ..
114 * .. Scalars in Common ..
115 LOGICAL LERR, OK
116 CHARACTER*32 SRNAMT
117 INTEGER INFOT, NUNIT
118 * ..
119 * .. Common blocks ..
120 COMMON / INFOC / INFOT, NUNIT, OK, LERR
121 COMMON / SRNAMC / SRNAMT
122 * ..
123 * .. Intrinsic Functions ..
124 INTRINSIC MAX, MIN
125 * ..
126 * .. Data statements ..
127 DATA ISEEDY / 1988, 1989, 1990, 1991 /
128 DATA FACTS / 'F', 'N' /
129 * ..
130 * .. Executable Statements ..
131 *
132 * Initialize constants and the random number seed.
133 *
134 PATH( 1: 1 ) = 'Double precision'
135 PATH( 2: 3 ) = 'SP'
136 NRUN = 0
137 NFAIL = 0
138 NERRS = 0
139 DO 10 I = 1, 4
140 ISEED( I ) = ISEEDY( I )
141 10 CONTINUE
142 LWORK = MAX( 2*NMAX, NMAX*NRHS )
143 *
144 * Test the error exits
145 *
146 IF( TSTERR )
147 $ CALL DERRVX( PATH, NOUT )
148 INFOT = 0
149 *
150 * Do for each value of N in NVAL
151 *
152 DO 180 IN = 1, NN
153 N = NVAL( IN )
154 LDA = MAX( N, 1 )
155 NPP = N*( N+1 ) / 2
156 XTYPE = 'N'
157 NIMAT = NTYPES
158 IF( N.LE.0 )
159 $ NIMAT = 1
160 *
161 DO 170 IMAT = 1, NIMAT
162 *
163 * Do the tests only if DOTYPE( IMAT ) is true.
164 *
165 IF( .NOT.DOTYPE( IMAT ) )
166 $ GO TO 170
167 *
168 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
169 *
170 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
171 IF( ZEROT .AND. N.LT.IMAT-2 )
172 $ GO TO 170
173 *
174 * Do first for UPLO = 'U', then for UPLO = 'L'
175 *
176 DO 160 IUPLO = 1, 2
177 IF( IUPLO.EQ.1 ) THEN
178 UPLO = 'U'
179 PACKIT = 'C'
180 ELSE
181 UPLO = 'L'
182 PACKIT = 'R'
183 END IF
184 *
185 * Set up parameters with DLATB4 and generate a test matrix
186 * with DLATMS.
187 *
188 CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
189 $ CNDNUM, DIST )
190 *
191 SRNAMT = 'DLATMS'
192 CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
193 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
194 $ INFO )
195 *
196 * Check error code from DLATMS.
197 *
198 IF( INFO.NE.0 ) THEN
199 CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
200 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
201 GO TO 160
202 END IF
203 *
204 * For types 3-6, zero one or more rows and columns of the
205 * matrix to test that INFO is returned correctly.
206 *
207 IF( ZEROT ) THEN
208 IF( IMAT.EQ.3 ) THEN
209 IZERO = 1
210 ELSE IF( IMAT.EQ.4 ) THEN
211 IZERO = N
212 ELSE
213 IZERO = N / 2 + 1
214 END IF
215 *
216 IF( IMAT.LT.6 ) THEN
217 *
218 * Set row and column IZERO to zero.
219 *
220 IF( IUPLO.EQ.1 ) THEN
221 IOFF = ( IZERO-1 )*IZERO / 2
222 DO 20 I = 1, IZERO - 1
223 A( IOFF+I ) = ZERO
224 20 CONTINUE
225 IOFF = IOFF + IZERO
226 DO 30 I = IZERO, N
227 A( IOFF ) = ZERO
228 IOFF = IOFF + I
229 30 CONTINUE
230 ELSE
231 IOFF = IZERO
232 DO 40 I = 1, IZERO - 1
233 A( IOFF ) = ZERO
234 IOFF = IOFF + N - I
235 40 CONTINUE
236 IOFF = IOFF - IZERO
237 DO 50 I = IZERO, N
238 A( IOFF+I ) = ZERO
239 50 CONTINUE
240 END IF
241 ELSE
242 IOFF = 0
243 IF( IUPLO.EQ.1 ) THEN
244 *
245 * Set the first IZERO rows and columns to zero.
246 *
247 DO 70 J = 1, N
248 I2 = MIN( J, IZERO )
249 DO 60 I = 1, I2
250 A( IOFF+I ) = ZERO
251 60 CONTINUE
252 IOFF = IOFF + J
253 70 CONTINUE
254 ELSE
255 *
256 * Set the last IZERO rows and columns to zero.
257 *
258 DO 90 J = 1, N
259 I1 = MAX( J, IZERO )
260 DO 80 I = I1, N
261 A( IOFF+I ) = ZERO
262 80 CONTINUE
263 IOFF = IOFF + N - J
264 90 CONTINUE
265 END IF
266 END IF
267 ELSE
268 IZERO = 0
269 END IF
270 *
271 DO 150 IFACT = 1, NFACT
272 *
273 * Do first for FACT = 'F', then for other values.
274 *
275 FACT = FACTS( IFACT )
276 *
277 * Compute the condition number for comparison with
278 * the value returned by DSPSVX.
279 *
280 IF( ZEROT ) THEN
281 IF( IFACT.EQ.1 )
282 $ GO TO 150
283 RCONDC = ZERO
284 *
285 ELSE IF( IFACT.EQ.1 ) THEN
286 *
287 * Compute the 1-norm of A.
288 *
289 ANORM = DLANSP( '1', UPLO, N, A, RWORK )
290 *
291 * Factor the matrix A.
292 *
293 CALL DCOPY( NPP, A, 1, AFAC, 1 )
294 CALL DSPTRF( UPLO, N, AFAC, IWORK, INFO )
295 *
296 * Compute inv(A) and take its norm.
297 *
298 CALL DCOPY( NPP, AFAC, 1, AINV, 1 )
299 CALL DSPTRI( UPLO, N, AINV, IWORK, WORK, INFO )
300 AINVNM = DLANSP( '1', UPLO, N, AINV, RWORK )
301 *
302 * Compute the 1-norm condition number of A.
303 *
304 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
305 RCONDC = ONE
306 ELSE
307 RCONDC = ( ONE / ANORM ) / AINVNM
308 END IF
309 END IF
310 *
311 * Form an exact solution and set the right hand side.
312 *
313 SRNAMT = 'DLARHS'
314 CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
315 $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
316 $ INFO )
317 XTYPE = 'C'
318 *
319 * --- Test DSPSV ---
320 *
321 IF( IFACT.EQ.2 ) THEN
322 CALL DCOPY( NPP, A, 1, AFAC, 1 )
323 CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
324 *
325 * Factor the matrix and solve the system using DSPSV.
326 *
327 SRNAMT = 'DSPSV '
328 CALL DSPSV( UPLO, N, NRHS, AFAC, IWORK, X, LDA,
329 $ INFO )
330 *
331 * Adjust the expected value of INFO to account for
332 * pivoting.
333 *
334 K = IZERO
335 IF( K.GT.0 ) THEN
336 100 CONTINUE
337 IF( IWORK( K ).LT.0 ) THEN
338 IF( IWORK( K ).NE.-K ) THEN
339 K = -IWORK( K )
340 GO TO 100
341 END IF
342 ELSE IF( IWORK( K ).NE.K ) THEN
343 K = IWORK( K )
344 GO TO 100
345 END IF
346 END IF
347 *
348 * Check error code from DSPSV .
349 *
350 IF( INFO.NE.K ) THEN
351 CALL ALAERH( PATH, 'DSPSV ', INFO, K, UPLO, N,
352 $ N, -1, -1, NRHS, IMAT, NFAIL,
353 $ NERRS, NOUT )
354 GO TO 120
355 ELSE IF( INFO.NE.0 ) THEN
356 GO TO 120
357 END IF
358 *
359 * Reconstruct matrix from factors and compute
360 * residual.
361 *
362 CALL DSPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA,
363 $ RWORK, RESULT( 1 ) )
364 *
365 * Compute residual of the computed solution.
366 *
367 CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
368 CALL DPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
369 $ RWORK, RESULT( 2 ) )
370 *
371 * Check solution from generated exact solution.
372 *
373 CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
374 $ RESULT( 3 ) )
375 NT = 3
376 *
377 * Print information about the tests that did not pass
378 * the threshold.
379 *
380 DO 110 K = 1, NT
381 IF( RESULT( K ).GE.THRESH ) THEN
382 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
383 $ CALL ALADHD( NOUT, PATH )
384 WRITE( NOUT, FMT = 9999 )'DSPSV ', UPLO, N,
385 $ IMAT, K, RESULT( K )
386 NFAIL = NFAIL + 1
387 END IF
388 110 CONTINUE
389 NRUN = NRUN + NT
390 120 CONTINUE
391 END IF
392 *
393 * --- Test DSPSVX ---
394 *
395 IF( IFACT.EQ.2 .AND. NPP.GT.0 )
396 $ CALL DLASET( 'Full', NPP, 1, ZERO, ZERO, AFAC,
397 $ NPP )
398 CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
399 *
400 * Solve the system and compute the condition number and
401 * error bounds using DSPSVX.
402 *
403 SRNAMT = 'DSPSVX'
404 CALL DSPSVX( FACT, UPLO, N, NRHS, A, AFAC, IWORK, B,
405 $ LDA, X, LDA, RCOND, RWORK,
406 $ RWORK( NRHS+1 ), WORK, IWORK( N+1 ),
407 $ INFO )
408 *
409 * Adjust the expected value of INFO to account for
410 * pivoting.
411 *
412 K = IZERO
413 IF( K.GT.0 ) THEN
414 130 CONTINUE
415 IF( IWORK( K ).LT.0 ) THEN
416 IF( IWORK( K ).NE.-K ) THEN
417 K = -IWORK( K )
418 GO TO 130
419 END IF
420 ELSE IF( IWORK( K ).NE.K ) THEN
421 K = IWORK( K )
422 GO TO 130
423 END IF
424 END IF
425 *
426 * Check the error code from DSPSVX.
427 *
428 IF( INFO.NE.K ) THEN
429 CALL ALAERH( PATH, 'DSPSVX', INFO, K, FACT // UPLO,
430 $ N, N, -1, -1, NRHS, IMAT, NFAIL,
431 $ NERRS, NOUT )
432 GO TO 150
433 END IF
434 *
435 IF( INFO.EQ.0 ) THEN
436 IF( IFACT.GE.2 ) THEN
437 *
438 * Reconstruct matrix from factors and compute
439 * residual.
440 *
441 CALL DSPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA,
442 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
443 K1 = 1
444 ELSE
445 K1 = 2
446 END IF
447 *
448 * Compute residual of the computed solution.
449 *
450 CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
451 CALL DPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
452 $ RWORK( 2*NRHS+1 ), RESULT( 2 ) )
453 *
454 * Check solution from generated exact solution.
455 *
456 CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
457 $ RESULT( 3 ) )
458 *
459 * Check the error bounds from iterative refinement.
460 *
461 CALL DPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA,
462 $ XACT, LDA, RWORK, RWORK( NRHS+1 ),
463 $ RESULT( 4 ) )
464 ELSE
465 K1 = 6
466 END IF
467 *
468 * Compare RCOND from DSPSVX with the computed value
469 * in RCONDC.
470 *
471 RESULT( 6 ) = DGET06( RCOND, RCONDC )
472 *
473 * Print information about the tests that did not pass
474 * the threshold.
475 *
476 DO 140 K = K1, 6
477 IF( RESULT( K ).GE.THRESH ) THEN
478 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
479 $ CALL ALADHD( NOUT, PATH )
480 WRITE( NOUT, FMT = 9998 )'DSPSVX', FACT, UPLO,
481 $ N, IMAT, K, RESULT( K )
482 NFAIL = NFAIL + 1
483 END IF
484 140 CONTINUE
485 NRUN = NRUN + 7 - K1
486 *
487 150 CONTINUE
488 *
489 160 CONTINUE
490 170 CONTINUE
491 180 CONTINUE
492 *
493 * Print a summary of the results.
494 *
495 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
496 *
497 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
498 $ ', test ', I2, ', ratio =', G12.5 )
499 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
500 $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
501 RETURN
502 *
503 * End of DDRVSP
504 *
505 END
2 $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
3 $ NOUT )
4 *
5 * -- LAPACK test routine (version 3.1) --
6 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
7 * November 2006
8 *
9 * .. Scalar Arguments ..
10 LOGICAL TSTERR
11 INTEGER NMAX, NN, NOUT, NRHS
12 DOUBLE PRECISION THRESH
13 * ..
14 * .. Array Arguments ..
15 LOGICAL DOTYPE( * )
16 INTEGER IWORK( * ), NVAL( * )
17 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
18 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
19 * ..
20 *
21 * Purpose
22 * =======
23 *
24 * DDRVSP tests the driver routines DSPSV and -SVX.
25 *
26 * Arguments
27 * =========
28 *
29 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
30 * The matrix types to be used for testing. Matrices of type j
31 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
32 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
33 *
34 * NN (input) INTEGER
35 * The number of values of N contained in the vector NVAL.
36 *
37 * NVAL (input) INTEGER array, dimension (NN)
38 * The values of the matrix dimension N.
39 *
40 * NRHS (input) INTEGER
41 * The number of right hand side vectors to be generated for
42 * each linear system.
43 *
44 * THRESH (input) DOUBLE PRECISION
45 * The threshold value for the test ratios. A result is
46 * included in the output file if RESULT >= THRESH. To have
47 * every test ratio printed, use THRESH = 0.
48 *
49 * TSTERR (input) LOGICAL
50 * Flag that indicates whether error exits are to be tested.
51 *
52 * NMAX (input) INTEGER
53 * The maximum value permitted for N, used in dimensioning the
54 * work arrays.
55 *
56 * A (workspace) DOUBLE PRECISION array, dimension
57 * (NMAX*(NMAX+1)/2)
58 *
59 * AFAC (workspace) DOUBLE PRECISION array, dimension
60 * (NMAX*(NMAX+1)/2)
61 *
62 * AINV (workspace) DOUBLE PRECISION array, dimension
63 * (NMAX*(NMAX+1)/2)
64 *
65 * B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
66 *
67 * X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
68 *
69 * XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS)
70 *
71 * WORK (workspace) DOUBLE PRECISION array, dimension
72 * (NMAX*max(2,NRHS))
73 *
74 * RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
75 *
76 * IWORK (workspace) INTEGER array, dimension (2*NMAX)
77 *
78 * NOUT (input) INTEGER
79 * The unit number for output.
80 *
81 * =====================================================================
82 *
83 * .. Parameters ..
84 DOUBLE PRECISION ONE, ZERO
85 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
86 INTEGER NTYPES, NTESTS
87 PARAMETER ( NTYPES = 10, NTESTS = 6 )
88 INTEGER NFACT
89 PARAMETER ( NFACT = 2 )
90 * ..
91 * .. Local Scalars ..
92 LOGICAL ZEROT
93 CHARACTER DIST, FACT, PACKIT, TYPE, UPLO, XTYPE
94 CHARACTER*3 PATH
95 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
96 $ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N,
97 $ NERRS, NFAIL, NIMAT, NPP, NRUN, NT
98 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
99 * ..
100 * .. Local Arrays ..
101 CHARACTER FACTS( NFACT )
102 INTEGER ISEED( 4 ), ISEEDY( 4 )
103 DOUBLE PRECISION RESULT( NTESTS )
104 * ..
105 * .. External Functions ..
106 DOUBLE PRECISION DGET06, DLANSP
107 EXTERNAL DGET06, DLANSP
108 * ..
109 * .. External Subroutines ..
110 EXTERNAL ALADHD, ALAERH, ALASVM, DCOPY, DERRVX, DGET04,
111 $ DLACPY, DLARHS, DLASET, DLATB4, DLATMS, DPPT02,
112 $ DPPT05, DSPSV, DSPSVX, DSPT01, DSPTRF, DSPTRI
113 * ..
114 * .. Scalars in Common ..
115 LOGICAL LERR, OK
116 CHARACTER*32 SRNAMT
117 INTEGER INFOT, NUNIT
118 * ..
119 * .. Common blocks ..
120 COMMON / INFOC / INFOT, NUNIT, OK, LERR
121 COMMON / SRNAMC / SRNAMT
122 * ..
123 * .. Intrinsic Functions ..
124 INTRINSIC MAX, MIN
125 * ..
126 * .. Data statements ..
127 DATA ISEEDY / 1988, 1989, 1990, 1991 /
128 DATA FACTS / 'F', 'N' /
129 * ..
130 * .. Executable Statements ..
131 *
132 * Initialize constants and the random number seed.
133 *
134 PATH( 1: 1 ) = 'Double precision'
135 PATH( 2: 3 ) = 'SP'
136 NRUN = 0
137 NFAIL = 0
138 NERRS = 0
139 DO 10 I = 1, 4
140 ISEED( I ) = ISEEDY( I )
141 10 CONTINUE
142 LWORK = MAX( 2*NMAX, NMAX*NRHS )
143 *
144 * Test the error exits
145 *
146 IF( TSTERR )
147 $ CALL DERRVX( PATH, NOUT )
148 INFOT = 0
149 *
150 * Do for each value of N in NVAL
151 *
152 DO 180 IN = 1, NN
153 N = NVAL( IN )
154 LDA = MAX( N, 1 )
155 NPP = N*( N+1 ) / 2
156 XTYPE = 'N'
157 NIMAT = NTYPES
158 IF( N.LE.0 )
159 $ NIMAT = 1
160 *
161 DO 170 IMAT = 1, NIMAT
162 *
163 * Do the tests only if DOTYPE( IMAT ) is true.
164 *
165 IF( .NOT.DOTYPE( IMAT ) )
166 $ GO TO 170
167 *
168 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
169 *
170 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
171 IF( ZEROT .AND. N.LT.IMAT-2 )
172 $ GO TO 170
173 *
174 * Do first for UPLO = 'U', then for UPLO = 'L'
175 *
176 DO 160 IUPLO = 1, 2
177 IF( IUPLO.EQ.1 ) THEN
178 UPLO = 'U'
179 PACKIT = 'C'
180 ELSE
181 UPLO = 'L'
182 PACKIT = 'R'
183 END IF
184 *
185 * Set up parameters with DLATB4 and generate a test matrix
186 * with DLATMS.
187 *
188 CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
189 $ CNDNUM, DIST )
190 *
191 SRNAMT = 'DLATMS'
192 CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
193 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
194 $ INFO )
195 *
196 * Check error code from DLATMS.
197 *
198 IF( INFO.NE.0 ) THEN
199 CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
200 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
201 GO TO 160
202 END IF
203 *
204 * For types 3-6, zero one or more rows and columns of the
205 * matrix to test that INFO is returned correctly.
206 *
207 IF( ZEROT ) THEN
208 IF( IMAT.EQ.3 ) THEN
209 IZERO = 1
210 ELSE IF( IMAT.EQ.4 ) THEN
211 IZERO = N
212 ELSE
213 IZERO = N / 2 + 1
214 END IF
215 *
216 IF( IMAT.LT.6 ) THEN
217 *
218 * Set row and column IZERO to zero.
219 *
220 IF( IUPLO.EQ.1 ) THEN
221 IOFF = ( IZERO-1 )*IZERO / 2
222 DO 20 I = 1, IZERO - 1
223 A( IOFF+I ) = ZERO
224 20 CONTINUE
225 IOFF = IOFF + IZERO
226 DO 30 I = IZERO, N
227 A( IOFF ) = ZERO
228 IOFF = IOFF + I
229 30 CONTINUE
230 ELSE
231 IOFF = IZERO
232 DO 40 I = 1, IZERO - 1
233 A( IOFF ) = ZERO
234 IOFF = IOFF + N - I
235 40 CONTINUE
236 IOFF = IOFF - IZERO
237 DO 50 I = IZERO, N
238 A( IOFF+I ) = ZERO
239 50 CONTINUE
240 END IF
241 ELSE
242 IOFF = 0
243 IF( IUPLO.EQ.1 ) THEN
244 *
245 * Set the first IZERO rows and columns to zero.
246 *
247 DO 70 J = 1, N
248 I2 = MIN( J, IZERO )
249 DO 60 I = 1, I2
250 A( IOFF+I ) = ZERO
251 60 CONTINUE
252 IOFF = IOFF + J
253 70 CONTINUE
254 ELSE
255 *
256 * Set the last IZERO rows and columns to zero.
257 *
258 DO 90 J = 1, N
259 I1 = MAX( J, IZERO )
260 DO 80 I = I1, N
261 A( IOFF+I ) = ZERO
262 80 CONTINUE
263 IOFF = IOFF + N - J
264 90 CONTINUE
265 END IF
266 END IF
267 ELSE
268 IZERO = 0
269 END IF
270 *
271 DO 150 IFACT = 1, NFACT
272 *
273 * Do first for FACT = 'F', then for other values.
274 *
275 FACT = FACTS( IFACT )
276 *
277 * Compute the condition number for comparison with
278 * the value returned by DSPSVX.
279 *
280 IF( ZEROT ) THEN
281 IF( IFACT.EQ.1 )
282 $ GO TO 150
283 RCONDC = ZERO
284 *
285 ELSE IF( IFACT.EQ.1 ) THEN
286 *
287 * Compute the 1-norm of A.
288 *
289 ANORM = DLANSP( '1', UPLO, N, A, RWORK )
290 *
291 * Factor the matrix A.
292 *
293 CALL DCOPY( NPP, A, 1, AFAC, 1 )
294 CALL DSPTRF( UPLO, N, AFAC, IWORK, INFO )
295 *
296 * Compute inv(A) and take its norm.
297 *
298 CALL DCOPY( NPP, AFAC, 1, AINV, 1 )
299 CALL DSPTRI( UPLO, N, AINV, IWORK, WORK, INFO )
300 AINVNM = DLANSP( '1', UPLO, N, AINV, RWORK )
301 *
302 * Compute the 1-norm condition number of A.
303 *
304 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
305 RCONDC = ONE
306 ELSE
307 RCONDC = ( ONE / ANORM ) / AINVNM
308 END IF
309 END IF
310 *
311 * Form an exact solution and set the right hand side.
312 *
313 SRNAMT = 'DLARHS'
314 CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
315 $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
316 $ INFO )
317 XTYPE = 'C'
318 *
319 * --- Test DSPSV ---
320 *
321 IF( IFACT.EQ.2 ) THEN
322 CALL DCOPY( NPP, A, 1, AFAC, 1 )
323 CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
324 *
325 * Factor the matrix and solve the system using DSPSV.
326 *
327 SRNAMT = 'DSPSV '
328 CALL DSPSV( UPLO, N, NRHS, AFAC, IWORK, X, LDA,
329 $ INFO )
330 *
331 * Adjust the expected value of INFO to account for
332 * pivoting.
333 *
334 K = IZERO
335 IF( K.GT.0 ) THEN
336 100 CONTINUE
337 IF( IWORK( K ).LT.0 ) THEN
338 IF( IWORK( K ).NE.-K ) THEN
339 K = -IWORK( K )
340 GO TO 100
341 END IF
342 ELSE IF( IWORK( K ).NE.K ) THEN
343 K = IWORK( K )
344 GO TO 100
345 END IF
346 END IF
347 *
348 * Check error code from DSPSV .
349 *
350 IF( INFO.NE.K ) THEN
351 CALL ALAERH( PATH, 'DSPSV ', INFO, K, UPLO, N,
352 $ N, -1, -1, NRHS, IMAT, NFAIL,
353 $ NERRS, NOUT )
354 GO TO 120
355 ELSE IF( INFO.NE.0 ) THEN
356 GO TO 120
357 END IF
358 *
359 * Reconstruct matrix from factors and compute
360 * residual.
361 *
362 CALL DSPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA,
363 $ RWORK, RESULT( 1 ) )
364 *
365 * Compute residual of the computed solution.
366 *
367 CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
368 CALL DPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
369 $ RWORK, RESULT( 2 ) )
370 *
371 * Check solution from generated exact solution.
372 *
373 CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
374 $ RESULT( 3 ) )
375 NT = 3
376 *
377 * Print information about the tests that did not pass
378 * the threshold.
379 *
380 DO 110 K = 1, NT
381 IF( RESULT( K ).GE.THRESH ) THEN
382 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
383 $ CALL ALADHD( NOUT, PATH )
384 WRITE( NOUT, FMT = 9999 )'DSPSV ', UPLO, N,
385 $ IMAT, K, RESULT( K )
386 NFAIL = NFAIL + 1
387 END IF
388 110 CONTINUE
389 NRUN = NRUN + NT
390 120 CONTINUE
391 END IF
392 *
393 * --- Test DSPSVX ---
394 *
395 IF( IFACT.EQ.2 .AND. NPP.GT.0 )
396 $ CALL DLASET( 'Full', NPP, 1, ZERO, ZERO, AFAC,
397 $ NPP )
398 CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
399 *
400 * Solve the system and compute the condition number and
401 * error bounds using DSPSVX.
402 *
403 SRNAMT = 'DSPSVX'
404 CALL DSPSVX( FACT, UPLO, N, NRHS, A, AFAC, IWORK, B,
405 $ LDA, X, LDA, RCOND, RWORK,
406 $ RWORK( NRHS+1 ), WORK, IWORK( N+1 ),
407 $ INFO )
408 *
409 * Adjust the expected value of INFO to account for
410 * pivoting.
411 *
412 K = IZERO
413 IF( K.GT.0 ) THEN
414 130 CONTINUE
415 IF( IWORK( K ).LT.0 ) THEN
416 IF( IWORK( K ).NE.-K ) THEN
417 K = -IWORK( K )
418 GO TO 130
419 END IF
420 ELSE IF( IWORK( K ).NE.K ) THEN
421 K = IWORK( K )
422 GO TO 130
423 END IF
424 END IF
425 *
426 * Check the error code from DSPSVX.
427 *
428 IF( INFO.NE.K ) THEN
429 CALL ALAERH( PATH, 'DSPSVX', INFO, K, FACT // UPLO,
430 $ N, N, -1, -1, NRHS, IMAT, NFAIL,
431 $ NERRS, NOUT )
432 GO TO 150
433 END IF
434 *
435 IF( INFO.EQ.0 ) THEN
436 IF( IFACT.GE.2 ) THEN
437 *
438 * Reconstruct matrix from factors and compute
439 * residual.
440 *
441 CALL DSPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA,
442 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) )
443 K1 = 1
444 ELSE
445 K1 = 2
446 END IF
447 *
448 * Compute residual of the computed solution.
449 *
450 CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
451 CALL DPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
452 $ RWORK( 2*NRHS+1 ), RESULT( 2 ) )
453 *
454 * Check solution from generated exact solution.
455 *
456 CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
457 $ RESULT( 3 ) )
458 *
459 * Check the error bounds from iterative refinement.
460 *
461 CALL DPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA,
462 $ XACT, LDA, RWORK, RWORK( NRHS+1 ),
463 $ RESULT( 4 ) )
464 ELSE
465 K1 = 6
466 END IF
467 *
468 * Compare RCOND from DSPSVX with the computed value
469 * in RCONDC.
470 *
471 RESULT( 6 ) = DGET06( RCOND, RCONDC )
472 *
473 * Print information about the tests that did not pass
474 * the threshold.
475 *
476 DO 140 K = K1, 6
477 IF( RESULT( K ).GE.THRESH ) THEN
478 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
479 $ CALL ALADHD( NOUT, PATH )
480 WRITE( NOUT, FMT = 9998 )'DSPSVX', FACT, UPLO,
481 $ N, IMAT, K, RESULT( K )
482 NFAIL = NFAIL + 1
483 END IF
484 140 CONTINUE
485 NRUN = NRUN + 7 - K1
486 *
487 150 CONTINUE
488 *
489 160 CONTINUE
490 170 CONTINUE
491 180 CONTINUE
492 *
493 * Print a summary of the results.
494 *
495 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
496 *
497 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
498 $ ', test ', I2, ', ratio =', G12.5 )
499 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
500 $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
501 RETURN
502 *
503 * End of DDRVSP
504 *
505 END