191
192
193
194
195
196
197 LOGICAL TSTERR
198 INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT
199 DOUBLE PRECISION THRESH
200
201
202 LOGICAL DOTYPE( * )
203 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
204 $ NVAL( * )
205 DOUBLE PRECISION RWORK( * )
206 COMPLEX*16 A( * ), AFAC( * ), B( * ), WORK( * ), X( * ),
207 $ XACT( * )
208
209
210
211
212
213 DOUBLE PRECISION ONE, ZERO
214 parameter( one = 1.0d+0, zero = 0.0d+0 )
215 INTEGER NTYPES, NTESTS
216 parameter( ntypes = 8, ntests = 7 )
217 INTEGER NBW, NTRAN
218 parameter( nbw = 4, ntran = 3 )
219
220
221 LOGICAL TRFCON, ZEROT
222 CHARACTER DIST, NORM, TRANS, TYPE, XTYPE
223 CHARACTER*3 PATH
224 INTEGER I, I1, I2, IKL, IKU, IM, IMAT, IN, INB, INFO,
225 $ IOFF, IRHS, ITRAN, IZERO, J, K, KL, KOFF, KU,
226 $ LDA, LDAFAC, LDB, M, MODE, N, NB, NERRS, NFAIL,
227 $ NIMAT, NKL, NKU, NRHS, NRUN
228 DOUBLE PRECISION AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, RCOND,
229 $ RCONDC, RCONDI, RCONDO
230
231
232 CHARACTER TRANSS( NTRAN )
233 INTEGER ISEED( 4 ), ISEEDY( 4 ), KLVAL( NBW ),
234 $ KUVAL( NBW )
235 DOUBLE PRECISION RESULT( NTESTS )
236
237
238 DOUBLE PRECISION DGET06, ZLANGB, ZLANGE
240
241
246
247
248 INTRINSIC dcmplx, max, min
249
250
251 LOGICAL LERR, OK
252 CHARACTER*32 SRNAMT
253 INTEGER INFOT, NUNIT
254
255
256 COMMON / infoc / infot, nunit, ok, lerr
257 COMMON / srnamc / srnamt
258
259
260 DATA iseedy / 1988, 1989, 1990, 1991 / ,
261 $ transs / 'N', 'T', 'C' /
262
263
264
265
266
267 path( 1: 1 ) = 'Zomplex precision'
268 path( 2: 3 ) = 'GB'
269 nrun = 0
270 nfail = 0
271 nerrs = 0
272 DO 10 i = 1, 4
273 iseed( i ) = iseedy( i )
274 10 CONTINUE
275
276
277
278 IF( tsterr )
279 $
CALL zerrge( path, nout )
280 infot = 0
281
282
283
284 klval( 1 ) = 0
285 kuval( 1 ) = 0
286
287
288
289 DO 160 im = 1, nm
290 m = mval( im )
291
292
293
294 klval( 2 ) = m + ( m+1 ) / 4
295
296
297
298 klval( 3 ) = ( 3*m-1 ) / 4
299 klval( 4 ) = ( m+1 ) / 4
300
301
302
303 DO 150 in = 1, nn
304 n = nval( in )
305 xtype = 'N'
306
307
308
309 kuval( 2 ) = n + ( n+1 ) / 4
310
311
312
313 kuval( 3 ) = ( 3*n-1 ) / 4
314 kuval( 4 ) = ( n+1 ) / 4
315
316
317
318 nkl = min( m+1, 4 )
319 IF( n.EQ.0 )
320 $ nkl = 2
321 nku = min( n+1, 4 )
322 IF( m.EQ.0 )
323 $ nku = 2
324 nimat = ntypes
325 IF( m.LE.0 .OR. n.LE.0 )
326 $ nimat = 1
327
328 DO 140 ikl = 1, nkl
329
330
331
332
333
334 kl = klval( ikl )
335 DO 130 iku = 1, nku
336
337
338
339
340
341 ku = kuval( iku )
342
343
344
345
346 lda = kl + ku + 1
347 ldafac = 2*kl + ku + 1
348 IF( ( lda*n ).GT.la .OR. ( ldafac*n ).GT.lafac ) THEN
349 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
350 $
CALL alahd( nout, path )
351 IF( n*( kl+ku+1 ).GT.la ) THEN
352 WRITE( nout, fmt = 9999 )la, m, n, kl, ku,
353 $ n*( kl+ku+1 )
354 nerrs = nerrs + 1
355 END IF
356 IF( n*( 2*kl+ku+1 ).GT.lafac ) THEN
357 WRITE( nout, fmt = 9998 )lafac, m, n, kl, ku,
358 $ n*( 2*kl+ku+1 )
359 nerrs = nerrs + 1
360 END IF
361 GO TO 130
362 END IF
363
364 DO 120 imat = 1, nimat
365
366
367
368 IF( .NOT.dotype( imat ) )
369 $ GO TO 120
370
371
372
373
374 zerot = imat.GE.2 .AND. imat.LE.4
375 IF( zerot .AND. n.LT.imat-1 )
376 $ GO TO 120
377
378 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) ) THEN
379
380
381
382
383 CALL zlatb4( path, imat, m, n,
TYPE, KL, KU,
384 $ ANORM, MODE, CNDNUM, DIST )
385
386 koff = max( 1, ku+2-n )
387 DO 20 i = 1, koff - 1
388 a( i ) = zero
389 20 CONTINUE
390 srnamt = 'ZLATMS'
391 CALL zlatms( m, n, dist, iseed,
TYPE, RWORK,
392 $ MODE, CNDNUM, ANORM, KL, KU, 'Z',
393 $ A( KOFF ), LDA, WORK, INFO )
394
395
396
397 IF( info.NE.0 ) THEN
398 CALL alaerh( path,
'ZLATMS', info, 0,
' ', m,
399 $ n, kl, ku, -1, imat, nfail,
400 $ nerrs, nout )
401 GO TO 120
402 END IF
403 ELSE IF( izero.GT.0 ) THEN
404
405
406
407
408 CALL zcopy( i2-i1+1, b, 1, a( ioff+i1 ), 1 )
409 END IF
410
411
412
413
414 izero = 0
415 IF( zerot ) THEN
416 IF( imat.EQ.2 ) THEN
417 izero = 1
418 ELSE IF( imat.EQ.3 ) THEN
419 izero = min( m, n )
420 ELSE
421 izero = min( m, n ) / 2 + 1
422 END IF
423 ioff = ( izero-1 )*lda
424 IF( imat.LT.4 ) THEN
425
426
427
428 i1 = max( 1, ku+2-izero )
429 i2 = min( kl+ku+1, ku+1+( m-izero ) )
430 CALL zcopy( i2-i1+1, a( ioff+i1 ), 1, b, 1 )
431
432 DO 30 i = i1, i2
433 a( ioff+i ) = zero
434 30 CONTINUE
435 ELSE
436 DO 50 j = izero, n
437 DO 40 i = max( 1, ku+2-j ),
438 $ min( kl+ku+1, ku+1+( m-j ) )
439 a( ioff+i ) = zero
440 40 CONTINUE
441 ioff = ioff + lda
442 50 CONTINUE
443 END IF
444 END IF
445
446
447
448
449
450
451
452
453
454
455 DO 110 inb = 1, nnb
456 nb = nbval( inb )
458
459
460
461 IF( m.GT.0 .AND. n.GT.0 )
462 $
CALL zlacpy(
'Full', kl+ku+1, n, a, lda,
463 $ afac( kl+1 ), ldafac )
464 srnamt = 'ZGBTRF'
465 CALL zgbtrf( m, n, kl, ku, afac, ldafac, iwork,
466 $ info )
467
468
469
470 IF( info.NE.izero )
471 $
CALL alaerh( path,
'ZGBTRF', info, izero,
472 $ ' ', m, n, kl, ku, nb, imat,
473 $ nfail, nerrs, nout )
474 trfcon = .false.
475
476
477
478
479
480 CALL zgbt01( m, n, kl, ku, a, lda, afac, ldafac,
481 $ iwork, work, result( 1 ) )
482
483
484
485
486 IF( result( 1 ).GE.thresh ) THEN
487 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
488 $
CALL alahd( nout, path )
489 WRITE( nout, fmt = 9997 )m, n, kl, ku, nb,
490 $ imat, 1, result( 1 )
491 nfail = nfail + 1
492 END IF
493 nrun = nrun + 1
494
495
496
497
498 IF( inb.GT.1 .OR. m.NE.n )
499 $ GO TO 110
500
501 anormo =
zlangb(
'O', n, kl, ku, a, lda, rwork )
502 anormi =
zlangb(
'I', n, kl, ku, a, lda, rwork )
503
504 IF( info.EQ.0 ) THEN
505
506
507
508
509 ldb = max( 1, n )
510 CALL zlaset(
'Full', n, n, dcmplx( zero ),
511 $ dcmplx( one ), work, ldb )
512 srnamt = 'ZGBTRS'
513 CALL zgbtrs(
'No transpose', n, kl, ku, n,
514 $ afac, ldafac, iwork, work, ldb,
515 $ info )
516
517
518
519 ainvnm =
zlange(
'O', n, n, work, ldb,
520 $ rwork )
521 IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
522 rcondo = one
523 ELSE
524 rcondo = ( one / anormo ) / ainvnm
525 END IF
526
527
528
529
530 ainvnm =
zlange(
'I', n, n, work, ldb,
531 $ rwork )
532 IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
533 rcondi = one
534 ELSE
535 rcondi = ( one / anormi ) / ainvnm
536 END IF
537 ELSE
538
539
540
541 trfcon = .true.
542 rcondo = zero
543 rcondi = zero
544 END IF
545
546
547
548 IF( trfcon )
549 $ GO TO 90
550
551 DO 80 irhs = 1, nns
552 nrhs = nsval( irhs )
553 xtype = 'N'
554
555 DO 70 itran = 1, ntran
556 trans = transs( itran )
557 IF( itran.EQ.1 ) THEN
558 rcondc = rcondo
559 norm = 'O'
560 ELSE
561 rcondc = rcondi
562 norm = 'I'
563 END IF
564
565
566
567
568 srnamt = 'ZLARHS'
569 CALL zlarhs( path, xtype,
' ', trans, n,
570 $ n, kl, ku, nrhs, a, lda,
571 $ xact, ldb, b, ldb, iseed,
572 $ info )
573 xtype = 'C'
574 CALL zlacpy(
'Full', n, nrhs, b, ldb, x,
575 $ ldb )
576
577 srnamt = 'ZGBTRS'
578 CALL zgbtrs( trans, n, kl, ku, nrhs, afac,
579 $ ldafac, iwork, x, ldb, info )
580
581
582
583 IF( info.NE.0 )
584 $
CALL alaerh( path,
'ZGBTRS', info, 0,
585 $ trans, n, n, kl, ku, -1,
586 $ imat, nfail, nerrs, nout )
587
588 CALL zlacpy(
'Full', n, nrhs, b, ldb,
589 $ work, ldb )
590 CALL zgbt02( trans, m, n, kl, ku, nrhs, a,
591 $ lda, x, ldb, work, ldb,
592 $ rwork, result( 2 ) )
593
594
595
596
597
598 CALL zget04( n, nrhs, x, ldb, xact, ldb,
599 $ rcondc, result( 3 ) )
600
601
602
603
604
605 srnamt = 'ZGBRFS'
606 CALL zgbrfs( trans, n, kl, ku, nrhs, a,
607 $ lda, afac, ldafac, iwork, b,
608 $ ldb, x, ldb, rwork,
609 $ rwork( nrhs+1 ), work,
610 $ rwork( 2*nrhs+1 ), info )
611
612
613
614 IF( info.NE.0 )
615 $
CALL alaerh( path,
'ZGBRFS', info, 0,
616 $ trans, n, n, kl, ku, nrhs,
617 $ imat, nfail, nerrs, nout )
618
619 CALL zget04( n, nrhs, x, ldb, xact, ldb,
620 $ rcondc, result( 4 ) )
621 CALL zgbt05( trans, n, kl, ku, nrhs, a,
622 $ lda, b, ldb, x, ldb, xact,
623 $ ldb, rwork, rwork( nrhs+1 ),
624 $ result( 5 ) )
625
626
627
628
629 DO 60 k = 2, 6
630 IF( result( k ).GE.thresh ) THEN
631 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
632 $
CALL alahd( nout, path )
633 WRITE( nout, fmt = 9996 )trans, n,
634 $ kl, ku, nrhs, imat, k,
635 $ result( k )
636 nfail = nfail + 1
637 END IF
638 60 CONTINUE
639 nrun = nrun + 5
640 70 CONTINUE
641 80 CONTINUE
642
643
644
645
646 90 CONTINUE
647 DO 100 itran = 1, 2
648 IF( itran.EQ.1 ) THEN
649 anorm = anormo
650 rcondc = rcondo
651 norm = 'O'
652 ELSE
653 anorm = anormi
654 rcondc = rcondi
655 norm = 'I'
656 END IF
657 srnamt = 'ZGBCON'
658 CALL zgbcon( norm, n, kl, ku, afac, ldafac,
659 $ iwork, anorm, rcond, work,
660 $ rwork, info )
661
662
663
664 IF( info.NE.0 )
665 $
CALL alaerh( path,
'ZGBCON', info, 0,
666 $ norm, n, n, kl, ku, -1, imat,
667 $ nfail, nerrs, nout )
668
669 result( 7 ) =
dget06( rcond, rcondc )
670
671
672
673
674 IF( result( 7 ).GE.thresh ) THEN
675 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
676 $
CALL alahd( nout, path )
677 WRITE( nout, fmt = 9995 )norm, n, kl, ku,
678 $ imat, 7, result( 7 )
679 nfail = nfail + 1
680 END IF
681 nrun = nrun + 1
682 100 CONTINUE
683 110 CONTINUE
684 120 CONTINUE
685 130 CONTINUE
686 140 CONTINUE
687 150 CONTINUE
688 160 CONTINUE
689
690
691
692 CALL alasum( path, nout, nfail, nrun, nerrs )
693
694 9999 FORMAT( ' *** In ZCHKGB, LA=', i5, ' is too small for M=', i5,
695 $ ', N=', i5, ', KL=', i4, ', KU=', i4,
696 $ / ' ==> Increase LA to at least ', i5 )
697 9998 FORMAT( ' *** In ZCHKGB, LAFAC=', i5, ' is too small for M=', i5,
698 $ ', N=', i5, ', KL=', i4, ', KU=', i4,
699 $ / ' ==> Increase LAFAC to at least ', i5 )
700 9997 FORMAT( ' M =', i5, ', N =', i5, ', KL=', i5, ', KU=', i5,
701 $ ', NB =', i4, ', type ', i1, ', test(', i1, ')=', g12.5 )
702 9996 FORMAT( ' TRANS=''', a1, ''', N=', i5, ', KL=', i5, ', KU=', i5,
703 $ ', NRHS=', i3, ', type ', i1, ', test(', i1, ')=', g12.5 )
704 9995 FORMAT( ' NORM =''', a1, ''', N=', i5, ', KL=', i5, ', KU=', i5,
705 $ ',', 10x, ' type ', i1, ', test(', i1, ')=', g12.5 )
706
707 RETURN
708
709
710
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
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 alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
subroutine alahd(iounit, path)
ALAHD
double precision function dget06(rcond, rcondc)
DGET06
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
subroutine zgbcon(norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond, work, rwork, info)
ZGBCON
subroutine zgbrfs(trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZGBRFS
subroutine zgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
ZGBTRF
subroutine zgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
ZGBTRS
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
double precision function zlangb(norm, n, kl, ku, ab, ldab, work)
ZLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
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 ...
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.
subroutine zerrge(path, nunit)
ZERRGE
subroutine zgbt01(m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
ZGBT01
subroutine zgbt02(trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZGBT02
subroutine zgbt05(trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZGBT05
subroutine zget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
ZGET04
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