171
172
173
174
175
176 IMPLICIT NONE
177
178
179 LOGICAL TSTERR
180 INTEGER NN, NNB, NNS, NMAX, NOUT
181 REAL THRESH
182
183
184 LOGICAL DOTYPE( * )
185 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
186 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
187 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
188
189
190
191
192
193 REAL ZERO
194 parameter( zero = 0.0e+0 )
195 INTEGER NTYPES
196 parameter( ntypes = 10 )
197 INTEGER NTESTS
198 parameter( ntests = 9 )
199
200
201 LOGICAL ZEROT
202 CHARACTER DIST, TYPE, UPLO, XTYPE
203 CHARACTER*3 PATH, MATPATH
204 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
205 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
206 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
207 REAL ANORM, CNDNUM
208
209
210 CHARACTER UPLOS( 2 )
211 INTEGER ISEED( 4 ), ISEEDY( 4 )
212 REAL RESULT( NTESTS )
213
214
219
220
221 INTRINSIC max, min
222
223
224 LOGICAL LERR, OK
225 CHARACTER*32 SRNAMT
226 INTEGER INFOT, NUNIT
227
228
229 COMMON / infoc / infot, nunit, ok, lerr
230 COMMON / srnamc / srnamt
231
232
233 DATA iseedy / 1988, 1989, 1990, 1991 /
234 DATA uplos / 'U', 'L' /
235
236
237
238
239
240
241
242
243 path( 1: 1 ) = 'Single precision'
244 path( 2: 3 ) = 'S2'
245
246
247
248 matpath( 1: 1 ) = 'Single precision'
249 matpath( 2: 3 ) = 'SY'
250 nrun = 0
251 nfail = 0
252 nerrs = 0
253 DO 10 i = 1, 4
254 iseed( i ) = iseedy( i )
255 10 CONTINUE
256
257
258
259 IF( tsterr )
260 $
CALL serrsy( path, nout )
261 infot = 0
262
263
264
265
267
268
269
270 DO 180 in = 1, nn
271 n = nval( in )
272 IF( n .GT. nmax ) THEN
273 nfail = nfail + 1
274 WRITE(nout, 9995) 'M ', n, nmax
275 GO TO 180
276 END IF
277 lda = max( n, 1 )
278 xtype = 'N'
279 nimat = ntypes
280 IF( n.LE.0 )
281 $ nimat = 1
282
283 izero = 0
284
285
286
287 DO 170 imat = 1, nimat
288
289
290
291 IF( .NOT.dotype( imat ) )
292 $ GO TO 170
293
294
295
296 zerot = imat.GE.3 .AND. imat.LE.6
297 IF( zerot .AND. n.LT.imat-2 )
298 $ GO TO 170
299
300
301
302 DO 160 iuplo = 1, 2
303 uplo = uplos( iuplo )
304
305
306
307
308
309
310
311 CALL slatb4( matpath, imat, n, n,
TYPE, KL, KU,
312 $ ANORM, MODE, CNDNUM, DIST )
313
314
315
316 srnamt = 'SLATMS'
317 CALL slatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
318 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
319 $ INFO )
320
321
322
323 IF( info.NE.0 ) THEN
324 CALL alaerh( path,
'SLATMS', info, 0, uplo, n, n, -1,
325 $ -1, -1, imat, nfail, nerrs, nout )
326
327
328
329 GO TO 160
330 END IF
331
332
333
334
335
336 IF( zerot ) THEN
337 IF( imat.EQ.3 ) THEN
338 izero = 1
339 ELSE IF( imat.EQ.4 ) THEN
340 izero = n
341 ELSE
342 izero = n / 2 + 1
343 END IF
344
345 IF( imat.LT.6 ) THEN
346
347
348
349 IF( iuplo.EQ.1 ) THEN
350 ioff = ( izero-1 )*lda
351 DO 20 i = 1, izero - 1
352 a( ioff+i ) = zero
353 20 CONTINUE
354 ioff = ioff + izero
355 DO 30 i = izero, n
356 a( ioff ) = zero
357 ioff = ioff + lda
358 30 CONTINUE
359 ELSE
360 ioff = izero
361 DO 40 i = 1, izero - 1
362 a( ioff ) = zero
363 ioff = ioff + lda
364 40 CONTINUE
365 ioff = ioff - izero
366 DO 50 i = izero, n
367 a( ioff+i ) = zero
368 50 CONTINUE
369 END IF
370 ELSE
371 IF( iuplo.EQ.1 ) THEN
372
373
374
375 ioff = 0
376 DO 70 j = 1, n
377 i2 = min( j, izero )
378 DO 60 i = 1, i2
379 a( ioff+i ) = zero
380 60 CONTINUE
381 ioff = ioff + lda
382 70 CONTINUE
383 izero = 1
384 ELSE
385
386
387
388 ioff = 0
389 DO 90 j = 1, n
390 i1 = max( j, izero )
391 DO 80 i = i1, n
392 a( ioff+i ) = zero
393 80 CONTINUE
394 ioff = ioff + lda
395 90 CONTINUE
396 END IF
397 END IF
398 ELSE
399 izero = 0
400 END IF
401
402
403
404
405
406 DO 150 inb = 1, nnb
407
408
409
410
411 nb = nbval( inb )
413
414
415
416
417
418 CALL slacpy( uplo, n, n, a, lda, afac, lda )
419
420
421
422
423
424
425 srnamt = 'SSYTRF_AA_2STAGE'
426 lwork = min(n*nb, 3*nmax*nmax)
428 $ ainv, (3*nb+1)*n,
429 $ iwork, iwork( 1+n ),
430 $ work, lwork,
431 $ info )
432
433
434
435
436 IF( izero.GT.0 ) THEN
437 j = 1
438 k = izero
439 100 CONTINUE
440 IF( j.EQ.k ) THEN
441 k = iwork( j )
442 ELSE IF( iwork( j ).EQ.k ) THEN
443 k = j
444 END IF
445 IF( j.LT.k ) THEN
446 j = j + 1
447 GO TO 100
448 END IF
449 ELSE
450 k = 0
451 END IF
452
453
454
455 IF( info.NE.k ) THEN
456 CALL alaerh( path,
'SSYTRF_AA_2STAGE', info, k,
457 $ uplo, n, n, -1, -1, nb, imat, nfail,
458 $ nerrs, nout )
459 END IF
460
461
462
463
464
465
466
467 nt = 0
468
469
470
471
472
473 DO 110 k = 1, nt
474 IF( result( k ).GE.thresh ) THEN
475 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
476 $
CALL alahd( nout, path )
477 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
478 $ result( k )
479 nfail = nfail + 1
480 END IF
481 110 CONTINUE
482 nrun = nrun + nt
483
484
485
486 IF( info.NE.0 ) THEN
487 GO TO 140
488 END IF
489
490
491
492 DO 130 irhs = 1, nns
493 nrhs = nsval( irhs )
494
495
496
497
498
499
500
501 srnamt = 'SLARHS'
502 CALL slarhs( matpath, xtype, uplo,
' ', n, n,
503 $ kl, ku, nrhs, a, lda, xact, lda,
504 $ b, lda, iseed, info )
505 CALL slacpy(
'Full', n, nrhs, b, lda, x, lda )
506
507 srnamt = 'SSYTRS_AA_2STAGE'
508 lwork = max( 1, 3*n-2 )
510 $ ainv, (3*nb+1)*n, iwork, iwork( 1+n ),
511 $ x, lda, info )
512
513
514
515 IF( info.NE.0 ) THEN
516 IF( izero.EQ.0 ) THEN
517 CALL alaerh( path,
'SSYTRS_AA_2STAGE',
518 $ info, 0, uplo, n, n, -1, -1,
519 $ nrhs, imat, nfail, nerrs, nout )
520 END IF
521 ELSE
522 CALL slacpy(
'Full', n, nrhs, b, lda, work, lda
523 $ )
524
525
526
527 CALL spot02( uplo, n, nrhs, a, lda, x, lda,
528 $ work, lda, rwork, result( 2 ) )
529
530
531
532
533
534 DO 120 k = 2, 2
535 IF( result( k ).GE.thresh ) THEN
536 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
537 $
CALL alahd( nout, path )
538 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
539 $ imat, k, result( k )
540 nfail = nfail + 1
541 END IF
542 120 CONTINUE
543 END IF
544 nrun = nrun + 1
545
546
547
548 130 CONTINUE
549 140 CONTINUE
550 150 CONTINUE
551 160 CONTINUE
552 170 CONTINUE
553 180 CONTINUE
554
555
556
557 CALL alasum( path, nout, nfail, nrun, nerrs )
558
559 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
560 $ i2, ', test ', i2, ', ratio =', g12.5 )
561 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
562 $ i2, ', test(', i2, ') =', g12.5 )
563 9995 FORMAT( ' Invalid input value: ', a4, '=', i6, '; must be <=',
564 $ i6 )
565 RETURN
566
567
568
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
subroutine slarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
SLARHS
subroutine xlaenv(ispec, nvalue)
XLAENV
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
subroutine alahd(iounit, path)
ALAHD
subroutine ssytrf_aa_2stage(uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
SSYTRF_AA_2STAGE
subroutine ssytrs_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
SSYTRS_AA_2STAGE
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
subroutine serrsy(path, nunit)
SERRSY
subroutine slatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
SLATB4
subroutine slatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
SLATMS
subroutine spot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
SPOT02
subroutine ssyt01_aa(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
SSYT01_AA