159
160
161
162
163
164
165 LOGICAL TSTERR
166 INTEGER NMAX, NN, NOUT, NRHS
167 DOUBLE PRECISION THRESH
168
169
170 LOGICAL DOTYPE( * )
171 INTEGER NVAL( * )
172 DOUBLE PRECISION RWORK( * ), S( * )
173 COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ),
174 $ BSAV( * ), WORK( * ), X( * ), XACT( * )
175
176
177
178
179
180 DOUBLE PRECISION ONE, ZERO
181 parameter( one = 1.0d+0, zero = 0.0d+0 )
182 INTEGER NTYPES, NTESTS
183 parameter( ntypes = 8, ntests = 6 )
184 INTEGER NBW
185 parameter( nbw = 4 )
186
187
188 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
189 CHARACTER DIST, EQUED, FACT, PACKIT, TYPE, UPLO, XTYPE
190 CHARACTER*3 PATH
191 INTEGER I, I1, I2, IEQUED, IFACT, IKD, IMAT, IN, INFO,
192 $ IOFF, IUPLO, IW, IZERO, K, K1, KD, KL, KOFF,
193 $ KU, LDA, LDAB, MODE, N, NB, NBMIN, NERRS,
194 $ NFACT, NFAIL, NIMAT, NKD, NRUN, NT
195 DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
196 $ ROLDC, SCOND
197
198
199 CHARACTER EQUEDS( 2 ), FACTS( 3 )
200 INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
201 DOUBLE PRECISION RESULT( NTESTS )
202
203
204 LOGICAL LSAME
205 DOUBLE PRECISION DGET06, ZLANGE, ZLANHB
207
208
213
214
215 INTRINSIC dcmplx, max, min
216
217
218 LOGICAL LERR, OK
219 CHARACTER*32 SRNAMT
220 INTEGER INFOT, NUNIT
221
222
223 COMMON / infoc / infot, nunit, ok, lerr
224 COMMON / srnamc / srnamt
225
226
227 DATA iseedy / 1988, 1989, 1990, 1991 /
228 DATA facts / 'F', 'N', 'E' / , equeds / 'N', 'Y' /
229
230
231
232
233
234 path( 1: 1 ) = 'Zomplex precision'
235 path( 2: 3 ) = 'PB'
236 nrun = 0
237 nfail = 0
238 nerrs = 0
239 DO 10 i = 1, 4
240 iseed( i ) = iseedy( i )
241 10 CONTINUE
242
243
244
245 IF( tsterr )
246 $
CALL zerrvx( path, nout )
247 infot = 0
248 kdval( 1 ) = 0
249
250
251
252 nb = 1
253 nbmin = 2
256
257
258
259 DO 110 in = 1, nn
260 n = nval( in )
261 lda = max( n, 1 )
262 xtype = 'N'
263
264
265
266 nkd = max( 1, min( n, 4 ) )
267 nimat = ntypes
268 IF( n.EQ.0 )
269 $ nimat = 1
270
271 kdval( 2 ) = n + ( n+1 ) / 4
272 kdval( 3 ) = ( 3*n-1 ) / 4
273 kdval( 4 ) = ( n+1 ) / 4
274
275 DO 100 ikd = 1, nkd
276
277
278
279
280
281 kd = kdval( ikd )
282 ldab = kd + 1
283
284
285
286 DO 90 iuplo = 1, 2
287 koff = 1
288 IF( iuplo.EQ.1 ) THEN
289 uplo = 'U'
290 packit = 'Q'
291 koff = max( 1, kd+2-n )
292 ELSE
293 uplo = 'L'
294 packit = 'B'
295 END IF
296
297 DO 80 imat = 1, nimat
298
299
300
301 IF( .NOT.dotype( imat ) )
302 $ GO TO 80
303
304
305
306 zerot = imat.GE.2 .AND. imat.LE.4
307 IF( zerot .AND. n.LT.imat-1 )
308 $ GO TO 80
309
310 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) ) THEN
311
312
313
314
315 CALL zlatb4( path, imat, n, n,
TYPE, KL, KU, ANORM,
316 $ MODE, CNDNUM, DIST )
317
318 srnamt = 'ZLATMS'
319 CALL zlatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
320 $ CNDNUM, ANORM, KD, KD, PACKIT,
321 $ A( KOFF ), LDAB, WORK, INFO )
322
323
324
325 IF( info.NE.0 ) THEN
326 CALL alaerh( path,
'ZLATMS', info, 0, uplo, n,
327 $ n, -1, -1, -1, imat, nfail, nerrs,
328 $ nout )
329 GO TO 80
330 END IF
331 ELSE IF( izero.GT.0 ) THEN
332
333
334
335
336 iw = 2*lda + 1
337 IF( iuplo.EQ.1 ) THEN
338 ioff = ( izero-1 )*ldab + kd + 1
339 CALL zcopy( izero-i1, work( iw ), 1,
340 $ a( ioff-izero+i1 ), 1 )
341 iw = iw + izero - i1
342 CALL zcopy( i2-izero+1, work( iw ), 1,
343 $ a( ioff ), max( ldab-1, 1 ) )
344 ELSE
345 ioff = ( i1-1 )*ldab + 1
346 CALL zcopy( izero-i1, work( iw ), 1,
347 $ a( ioff+izero-i1 ),
348 $ max( ldab-1, 1 ) )
349 ioff = ( izero-1 )*ldab + 1
350 iw = iw + izero - i1
351 CALL zcopy( i2-izero+1, work( iw ), 1,
352 $ a( ioff ), 1 )
353 END IF
354 END IF
355
356
357
358
359 izero = 0
360 IF( zerot ) THEN
361 IF( imat.EQ.2 ) THEN
362 izero = 1
363 ELSE IF( imat.EQ.3 ) THEN
364 izero = n
365 ELSE
366 izero = n / 2 + 1
367 END IF
368
369
370
371 iw = 2*lda
372 DO 20 i = 1, min( 2*kd+1, n )
373 work( iw+i ) = zero
374 20 CONTINUE
375 iw = iw + 1
376 i1 = max( izero-kd, 1 )
377 i2 = min( izero+kd, n )
378
379 IF( iuplo.EQ.1 ) THEN
380 ioff = ( izero-1 )*ldab + kd + 1
381 CALL zswap( izero-i1, a( ioff-izero+i1 ), 1,
382 $ work( iw ), 1 )
383 iw = iw + izero - i1
384 CALL zswap( i2-izero+1, a( ioff ),
385 $ max( ldab-1, 1 ), work( iw ), 1 )
386 ELSE
387 ioff = ( i1-1 )*ldab + 1
388 CALL zswap( izero-i1, a( ioff+izero-i1 ),
389 $ max( ldab-1, 1 ), work( iw ), 1 )
390 ioff = ( izero-1 )*ldab + 1
391 iw = iw + izero - i1
392 CALL zswap( i2-izero+1, a( ioff ), 1,
393 $ work( iw ), 1 )
394 END IF
395 END IF
396
397
398
399 IF( iuplo.EQ.1 ) THEN
400 CALL zlaipd( n, a( kd+1 ), ldab, 0 )
401 ELSE
402 CALL zlaipd( n, a( 1 ), ldab, 0 )
403 END IF
404
405
406
407 CALL zlacpy(
'Full', kd+1, n, a, ldab, asav, ldab )
408
409 DO 70 iequed = 1, 2
410 equed = equeds( iequed )
411 IF( iequed.EQ.1 ) THEN
412 nfact = 3
413 ELSE
414 nfact = 1
415 END IF
416
417 DO 60 ifact = 1, nfact
418 fact = facts( ifact )
419 prefac =
lsame( fact,
'F' )
420 nofact =
lsame( fact,
'N' )
421 equil =
lsame( fact,
'E' )
422
423 IF( zerot ) THEN
424 IF( prefac )
425 $ GO TO 60
426 rcondc = zero
427
428 ELSE IF( .NOT.
lsame( fact,
'N' ) )
THEN
429
430
431
432
433
434
435 CALL zlacpy(
'Full', kd+1, n, asav, ldab,
436 $ afac, ldab )
437 IF( equil .OR. iequed.GT.1 ) THEN
438
439
440
441
442 CALL zpbequ( uplo, n, kd, afac, ldab, s,
443 $ scond, amax, info )
444 IF( info.EQ.0 .AND. n.GT.0 ) THEN
445 IF( iequed.GT.1 )
446 $ scond = zero
447
448
449
450 CALL zlaqhb( uplo, n, kd, afac, ldab,
451 $ s, scond, amax, equed )
452 END IF
453 END IF
454
455
456
457
458 IF( equil )
459 $ roldc = rcondc
460
461
462
463 anorm =
zlanhb(
'1', uplo, n, kd, afac, ldab,
464 $ rwork )
465
466
467
468 CALL zpbtrf( uplo, n, kd, afac, ldab, info )
469
470
471
472 CALL zlaset(
'Full', n, n, dcmplx( zero ),
473 $ dcmplx( one ), a, lda )
474 srnamt = 'ZPBTRS'
475 CALL zpbtrs( uplo, n, kd, n, afac, ldab, a,
476 $ lda, info )
477
478
479
480 ainvnm =
zlange(
'1', n, n, a, lda, rwork )
481 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
482 rcondc = one
483 ELSE
484 rcondc = ( one / anorm ) / ainvnm
485 END IF
486 END IF
487
488
489
490 CALL zlacpy(
'Full', kd+1, n, asav, ldab, a,
491 $ ldab )
492
493
494
495
496 srnamt = 'ZLARHS'
497 CALL zlarhs( path, xtype, uplo,
' ', n, n, kd,
498 $ kd, nrhs, a, ldab, xact, lda, b,
499 $ lda, iseed, info )
500 xtype = 'C'
501 CALL zlacpy(
'Full', n, nrhs, b, lda, bsav,
502 $ lda )
503
504 IF( nofact ) THEN
505
506
507
508
509
510
511 CALL zlacpy(
'Full', kd+1, n, a, ldab, afac,
512 $ ldab )
513 CALL zlacpy(
'Full', n, nrhs, b, lda, x,
514 $ lda )
515
516 srnamt = 'ZPBSV '
517 CALL zpbsv( uplo, n, kd, nrhs, afac, ldab, x,
518 $ lda, info )
519
520
521
522 IF( info.NE.izero ) THEN
523 CALL alaerh( path,
'ZPBSV ', info, izero,
524 $ uplo, n, n, kd, kd, nrhs,
525 $ imat, nfail, nerrs, nout )
526 GO TO 40
527 ELSE IF( info.NE.0 ) THEN
528 GO TO 40
529 END IF
530
531
532
533
534 CALL zpbt01( uplo, n, kd, a, ldab, afac,
535 $ ldab, rwork, result( 1 ) )
536
537
538
539 CALL zlacpy(
'Full', n, nrhs, b, lda, work,
540 $ lda )
541 CALL zpbt02( uplo, n, kd, nrhs, a, ldab, x,
542 $ lda, work, lda, rwork,
543 $ result( 2 ) )
544
545
546
547 CALL zget04( n, nrhs, x, lda, xact, lda,
548 $ rcondc, result( 3 ) )
549 nt = 3
550
551
552
553
554 DO 30 k = 1, nt
555 IF( result( k ).GE.thresh ) THEN
556 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
557 $
CALL aladhd( nout, path )
558 WRITE( nout, fmt = 9999 )'ZPBSV ',
559 $ uplo, n, kd, imat, k, result( k )
560 nfail = nfail + 1
561 END IF
562 30 CONTINUE
563 nrun = nrun + nt
564 40 CONTINUE
565 END IF
566
567
568
569 IF( .NOT.prefac )
570 $
CALL zlaset(
'Full', kd+1, n, dcmplx( zero ),
571 $ dcmplx( zero ), afac, ldab )
572 CALL zlaset(
'Full', n, nrhs, dcmplx( zero ),
573 $ dcmplx( zero ), x, lda )
574 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
575
576
577
578
579 CALL zlaqhb( uplo, n, kd, a, ldab, s, scond,
580 $ amax, equed )
581 END IF
582
583
584
585
586 srnamt = 'ZPBSVX'
587 CALL zpbsvx( fact, uplo, n, kd, nrhs, a, ldab,
588 $ afac, ldab, equed, s, b, lda, x,
589 $ lda, rcond, rwork, rwork( nrhs+1 ),
590 $ work, rwork( 2*nrhs+1 ), info )
591
592
593
594 IF( info.NE.izero ) THEN
595 CALL alaerh( path,
'ZPBSVX', info, izero,
596 $ fact // uplo, n, n, kd, kd,
597 $ nrhs, imat, nfail, nerrs, nout )
598 GO TO 60
599 END IF
600
601 IF( info.EQ.0 ) THEN
602 IF( .NOT.prefac ) THEN
603
604
605
606
607 CALL zpbt01( uplo, n, kd, a, ldab, afac,
608 $ ldab, rwork( 2*nrhs+1 ),
609 $ result( 1 ) )
610 k1 = 1
611 ELSE
612 k1 = 2
613 END IF
614
615
616
617 CALL zlacpy(
'Full', n, nrhs, bsav, lda,
618 $ work, lda )
619 CALL zpbt02( uplo, n, kd, nrhs, asav, ldab,
620 $ x, lda, work, lda,
621 $ rwork( 2*nrhs+1 ), result( 2 ) )
622
623
624
625 IF( nofact .OR. ( prefac .AND.
lsame( equed,
626 $ 'N' ) ) ) THEN
627 CALL zget04( n, nrhs, x, lda, xact, lda,
628 $ rcondc, result( 3 ) )
629 ELSE
630 CALL zget04( n, nrhs, x, lda, xact, lda,
631 $ roldc, result( 3 ) )
632 END IF
633
634
635
636
637 CALL zpbt05( uplo, n, kd, nrhs, asav, ldab,
638 $ b, lda, x, lda, xact, lda,
639 $ rwork, rwork( nrhs+1 ),
640 $ result( 4 ) )
641 ELSE
642 k1 = 6
643 END IF
644
645
646
647
648 result( 6 ) =
dget06( rcond, rcondc )
649
650
651
652
653 DO 50 k = k1, 6
654 IF( result( k ).GE.thresh ) THEN
655 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
656 $
CALL aladhd( nout, path )
657 IF( prefac ) THEN
658 WRITE( nout, fmt = 9997 )'ZPBSVX',
659 $ fact, uplo, n, kd, equed, imat, k,
660 $ result( k )
661 ELSE
662 WRITE( nout, fmt = 9998 )'ZPBSVX',
663 $ fact, uplo, n, kd, imat, k,
664 $ result( k )
665 END IF
666 nfail = nfail + 1
667 END IF
668 50 CONTINUE
669 nrun = nrun + 7 - k1
670 60 CONTINUE
671 70 CONTINUE
672 80 CONTINUE
673 90 CONTINUE
674 100 CONTINUE
675 110 CONTINUE
676
677
678
679 CALL alasvm( path, nout, nfail, nrun, nerrs )
680
681 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', KD =', i5,
682 $ ', type ', i1, ', test(', i1, ')=', g12.5 )
683 9998 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ', i5, ', ', i5,
684 $ ', ... ), type ', i1, ', test(', i1, ')=', g12.5 )
685 9997 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ', i5, ', ', i5,
686 $ ', ... ), EQUED=''', a1, ''', type ', i1, ', test(', i1,
687 $ ')=', g12.5 )
688 RETURN
689
690
691
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
subroutine xlaenv(ispec, nvalue)
XLAENV
subroutine zlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
ZLARHS
subroutine aladhd(iounit, path)
ALADHD
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
double precision function dget06(rcond, rcondc)
DGET06
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
double precision function zlange(norm, m, n, a, lda, work)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
double precision function zlanhb(norm, uplo, n, k, ab, ldab, work)
ZLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
subroutine zlaqhb(uplo, n, kd, ab, ldab, s, scond, amax, equed)
ZLAQHB scales a Hermitian band matrix, using scaling factors computed by cpbequ.
subroutine zlaset(uplo, m, n, alpha, beta, a, lda)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
logical function lsame(ca, cb)
LSAME
subroutine zpbequ(uplo, n, kd, ab, ldab, s, scond, amax, info)
ZPBEQU
subroutine zpbsv(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
ZPBSV computes the solution to system of linear equations A * X = B for OTHER matrices
subroutine zpbsvx(fact, uplo, n, kd, nrhs, ab, ldab, afb, ldafb, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices
subroutine zpbtrf(uplo, n, kd, ab, ldab, info)
ZPBTRF
subroutine zpbtrs(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
ZPBTRS
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
subroutine zerrvx(path, nunit)
ZERRVX
subroutine zget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
ZGET04
subroutine zlaipd(n, a, inda, vinda)
ZLAIPD
subroutine zlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
ZLATB4
subroutine zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS
subroutine zpbt01(uplo, n, kd, a, lda, afac, ldafac, rwork, resid)
ZPBT01
subroutine zpbt02(uplo, n, kd, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZPBT02
subroutine zpbt05(uplo, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZPBT05