159
160
161
162
163
164
165 LOGICAL TSTERR
166 INTEGER NMAX, NN, NOUT, NRHS
167 REAL THRESH
168
169
170 LOGICAL DOTYPE( * )
171 INTEGER NVAL( * )
172 REAL RWORK( * ), S( * )
173 COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ),
174 $ BSAV( * ), WORK( * ), X( * ), XACT( * )
175
176
177
178
179
180 REAL ONE, ZERO
181 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
202
203
204 LOGICAL LSAME
205 REAL CLANGE, CLANHB, SGET06
207
208
213
214
215 INTRINSIC cmplx, 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 ) = 'Complex 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 cerrvx( 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 clatb4( path, imat, n, n,
TYPE, KL, KU, ANORM,
316 $ MODE, CNDNUM, DIST )
317
318 srnamt = 'CLATMS'
319 CALL clatms( 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,
'CLATMS', 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 ccopy( izero-i1, work( iw ), 1,
340 $ a( ioff-izero+i1 ), 1 )
341 iw = iw + izero - i1
342 CALL ccopy( i2-izero+1, work( iw ), 1,
343 $ a( ioff ), max( ldab-1, 1 ) )
344 ELSE
345 ioff = ( i1-1 )*ldab + 1
346 CALL ccopy( 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 ccopy( 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 cswap( izero-i1, a( ioff-izero+i1 ), 1,
382 $ work( iw ), 1 )
383 iw = iw + izero - i1
384 CALL cswap( i2-izero+1, a( ioff ),
385 $ max( ldab-1, 1 ), work( iw ), 1 )
386 ELSE
387 ioff = ( i1-1 )*ldab + 1
388 CALL cswap( 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 cswap( 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 claipd( n, a( kd+1 ), ldab, 0 )
401 ELSE
402 CALL claipd( n, a( 1 ), ldab, 0 )
403 END IF
404
405
406
407 CALL clacpy(
'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 clacpy(
'Full', kd+1, n, asav, ldab,
436 $ afac, ldab )
437 IF( equil .OR. iequed.GT.1 ) THEN
438
439
440
441
442 CALL cpbequ( 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 claqhb( 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 =
clanhb(
'1', uplo, n, kd, afac, ldab,
464 $ rwork )
465
466
467
468 CALL cpbtrf( uplo, n, kd, afac, ldab, info )
469
470
471
472 CALL claset(
'Full', n, n, cmplx( zero ),
473 $ cmplx( one ), a, lda )
474 srnamt = 'CPBTRS'
475 CALL cpbtrs( uplo, n, kd, n, afac, ldab, a,
476 $ lda, info )
477
478
479
480 ainvnm =
clange(
'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 clacpy(
'Full', kd+1, n, asav, ldab, a,
491 $ ldab )
492
493
494
495
496 srnamt = 'CLARHS'
497 CALL clarhs( path, xtype, uplo,
' ', n, n, kd,
498 $ kd, nrhs, a, ldab, xact, lda, b,
499 $ lda, iseed, info )
500 xtype = 'C'
501 CALL clacpy(
'Full', n, nrhs, b, lda, bsav,
502 $ lda )
503
504 IF( nofact ) THEN
505
506
507
508
509
510
511 CALL clacpy(
'Full', kd+1, n, a, ldab, afac,
512 $ ldab )
513 CALL clacpy(
'Full', n, nrhs, b, lda, x,
514 $ lda )
515
516 srnamt = 'CPBSV '
517 CALL cpbsv( uplo, n, kd, nrhs, afac, ldab, x,
518 $ lda, info )
519
520
521
522 IF( info.NE.izero ) THEN
523 CALL alaerh( path,
'CPBSV ', 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 cpbt01( uplo, n, kd, a, ldab, afac,
535 $ ldab, rwork, result( 1 ) )
536
537
538
539 CALL clacpy(
'Full', n, nrhs, b, lda, work,
540 $ lda )
541 CALL cpbt02( uplo, n, kd, nrhs, a, ldab, x,
542 $ lda, work, lda, rwork,
543 $ result( 2 ) )
544
545
546
547 CALL cget04( 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 )'CPBSV ',
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 claset(
'Full', kd+1, n, cmplx( zero ),
571 $ cmplx( zero ), afac, ldab )
572 CALL claset(
'Full', n, nrhs, cmplx( zero ),
573 $ cmplx( zero ), x, lda )
574 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
575
576
577
578
579 CALL claqhb( uplo, n, kd, a, ldab, s, scond,
580 $ amax, equed )
581 END IF
582
583
584
585
586 srnamt = 'CPBSVX'
587 CALL cpbsvx( 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,
'CPBSVX', 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 cpbt01( 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 clacpy(
'Full', n, nrhs, bsav, lda,
618 $ work, lda )
619 CALL cpbt02( 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 cget04( n, nrhs, x, lda, xact, lda,
628 $ rcondc, result( 3 ) )
629 ELSE
630 CALL cget04( n, nrhs, x, lda, xact, lda,
631 $ roldc, result( 3 ) )
632 END IF
633
634
635
636
637 CALL cpbt05( 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 ) =
sget06( 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 )'CPBSVX',
659 $ fact, uplo, n, kd, equed, imat, k,
660 $ result( k )
661 ELSE
662 WRITE( nout, fmt = 9998 )'CPBSVX',
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 clarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
CLARHS
subroutine xlaenv(ispec, nvalue)
XLAENV
subroutine aladhd(iounit, path)
ALADHD
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
subroutine cerrvx(path, nunit)
CERRVX
subroutine cget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
CGET04
subroutine claipd(n, a, inda, vinda)
CLAIPD
subroutine clatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
CLATB4
subroutine clatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
CLATMS
subroutine cpbt01(uplo, n, kd, a, lda, afac, ldafac, rwork, resid)
CPBT01
subroutine cpbt02(uplo, n, kd, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CPBT02
subroutine cpbt05(uplo, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CPBT05
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
real function clange(norm, m, n, a, lda, work)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
real function clanhb(norm, uplo, n, k, ab, ldab, work)
CLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
subroutine claqhb(uplo, n, kd, ab, ldab, s, scond, amax, equed)
CLAQHB scales a Hermitian band matrix, using scaling factors computed by cpbequ.
subroutine claset(uplo, m, n, alpha, beta, a, lda)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
logical function lsame(ca, cb)
LSAME
subroutine cpbequ(uplo, n, kd, ab, ldab, s, scond, amax, info)
CPBEQU
subroutine cpbsv(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
CPBSV computes the solution to system of linear equations A * X = B for OTHER matrices
subroutine cpbsvx(fact, uplo, n, kd, nrhs, ab, ldab, afb, ldafb, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
CPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices
subroutine cpbtrf(uplo, n, kd, ab, ldab, info)
CPBTRF
subroutine cpbtrs(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
CPBTRS
subroutine cswap(n, cx, incx, cy, incy)
CSWAP
real function sget06(rcond, rcondc)
SGET06