172
173
174
175
176
177
178 LOGICAL TSTERR
179 INTEGER NMAX, NN, NNB, NNS, NOUT
180 REAL THRESH
181
182
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185 REAL RWORK( * )
186 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
187 $ WORK( * ), X( * ), XACT( * )
188
189
190
191
192
193 REAL ZERO, ONE
194 parameter( zero = 0.0e+0, one = 1.0e+0 )
195 REAL ONEHALF
196 parameter( onehalf = 0.5e+0 )
197 REAL EIGHT, SEVTEN
198 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
199 COMPLEX CZERO
200 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
201 INTEGER NTYPES
202 parameter( ntypes = 10 )
203 INTEGER NTESTS
204 parameter( ntests = 7 )
205
206
207 LOGICAL TRFCON, ZEROT
208 CHARACTER DIST, TYPE, UPLO, XTYPE
209 CHARACTER*3 PATH, MATPATH
210 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
211 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
212 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
213 REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
214 $ SING_MIN, RCOND, RCONDC, STEMP
215
216
217 CHARACTER UPLOS( 2 )
218 INTEGER ISEED( 4 ), ISEEDY( 4 )
219 REAL RESULT( NTESTS )
220 COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
221
222
223 REAL CLANGE, CLANHE, SGET06
225
226
231
232
233 INTRINSIC conjg, max, min, sqrt
234
235
236 LOGICAL LERR, OK
237 CHARACTER*32 SRNAMT
238 INTEGER INFOT, NUNIT
239
240
241 COMMON / infoc / infot, nunit, ok, lerr
242 COMMON / srnamc / srnamt
243
244
245 DATA iseedy / 1988, 1989, 1990, 1991 /
246 DATA uplos / 'U', 'L' /
247
248
249
250
251
252 alpha = ( one+sqrt( sevten ) ) / eight
253
254
255
256 path( 1: 1 ) = 'Complex precision'
257 path( 2: 3 ) = 'HR'
258
259
260
261 matpath( 1: 1 ) = 'Complex precision'
262 matpath( 2: 3 ) = 'HE'
263
264 nrun = 0
265 nfail = 0
266 nerrs = 0
267 DO 10 i = 1, 4
268 iseed( i ) = iseedy( i )
269 10 CONTINUE
270
271
272
273 IF( tsterr )
274 $
CALL cerrhe( path, nout )
275 infot = 0
276
277
278
279
281
282
283
284 DO 270 in = 1, nn
285 n = nval( in )
286 lda = max( n, 1 )
287 xtype = 'N'
288 nimat = ntypes
289 IF( n.LE.0 )
290 $ nimat = 1
291
292 izero = 0
293
294
295
296 DO 260 imat = 1, nimat
297
298
299
300 IF( .NOT.dotype( imat ) )
301 $ GO TO 260
302
303
304
305 zerot = imat.GE.3 .AND. imat.LE.6
306 IF( zerot .AND. n.LT.imat-2 )
307 $ GO TO 260
308
309
310
311 DO 250 iuplo = 1, 2
312 uplo = uplos( iuplo )
313
314
315
316
317
318
319 CALL clatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
320 $ MODE, CNDNUM, DIST )
321
322
323
324 srnamt = 'CLATMS'
325 CALL clatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
326 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
327 $ WORK, INFO )
328
329
330
331 IF( info.NE.0 ) THEN
332 CALL alaerh( path,
'CLATMS', info, 0, uplo, n, n,
333 $ -1, -1, -1, imat, nfail, nerrs, nout )
334
335
336
337 GO TO 250
338 END IF
339
340
341
342
343
344 IF( zerot ) THEN
345 IF( imat.EQ.3 ) THEN
346 izero = 1
347 ELSE IF( imat.EQ.4 ) THEN
348 izero = n
349 ELSE
350 izero = n / 2 + 1
351 END IF
352
353 IF( imat.LT.6 ) THEN
354
355
356
357 IF( iuplo.EQ.1 ) THEN
358 ioff = ( izero-1 )*lda
359 DO 20 i = 1, izero - 1
360 a( ioff+i ) = czero
361 20 CONTINUE
362 ioff = ioff + izero
363 DO 30 i = izero, n
364 a( ioff ) = czero
365 ioff = ioff + lda
366 30 CONTINUE
367 ELSE
368 ioff = izero
369 DO 40 i = 1, izero - 1
370 a( ioff ) = czero
371 ioff = ioff + lda
372 40 CONTINUE
373 ioff = ioff - izero
374 DO 50 i = izero, n
375 a( ioff+i ) = czero
376 50 CONTINUE
377 END IF
378 ELSE
379 IF( iuplo.EQ.1 ) THEN
380
381
382
383 ioff = 0
384 DO 70 j = 1, n
385 i2 = min( j, izero )
386 DO 60 i = 1, i2
387 a( ioff+i ) = czero
388 60 CONTINUE
389 ioff = ioff + lda
390 70 CONTINUE
391 ELSE
392
393
394
395 ioff = 0
396 DO 90 j = 1, n
397 i1 = max( j, izero )
398 DO 80 i = i1, n
399 a( ioff+i ) = czero
400 80 CONTINUE
401 ioff = ioff + lda
402 90 CONTINUE
403 END IF
404 END IF
405 ELSE
406 izero = 0
407 END IF
408
409
410
411
412
413
414 DO 240 inb = 1, nnb
415
416
417
418
419 nb = nbval( inb )
421
422
423
424
425
426 CALL clacpy( uplo, n, n, a, lda, afac, lda )
427
428
429
430
431
432
433 lwork = max( 2, nb )*lda
434 srnamt = 'CHETRF_ROOK'
436 $ lwork, info )
437
438
439
440
441 k = izero
442 IF( k.GT.0 ) THEN
443 100 CONTINUE
444 IF( iwork( k ).LT.0 ) THEN
445 IF( iwork( k ).NE.-k ) THEN
446 k = -iwork( k )
447 GO TO 100
448 END IF
449 ELSE IF( iwork( k ).NE.k ) THEN
450 k = iwork( k )
451 GO TO 100
452 END IF
453 END IF
454
455
456
457 IF( info.NE.k)
458 $
CALL alaerh( path,
'CHETRF_ROOK', info, k,
459 $ uplo, n, n, -1, -1, nb, imat,
460 $ nfail, nerrs, nout )
461
462
463
464 IF( info.NE.0 ) THEN
465 trfcon = .true.
466 ELSE
467 trfcon = .false.
468 END IF
469
470
471
472
473 CALL chet01_rook( uplo, n, a, lda, afac, lda, iwork,
474 $ ainv, lda, rwork, result( 1 ) )
475 nt = 1
476
477
478
479
480
481
482
483 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
484 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
485 srnamt = 'CHETRI_ROOK'
487 $ info )
488
489
490
491 IF( info.NE.0 )
492 $
CALL alaerh( path,
'CHETRI_ROOK', info, -1,
493 $ uplo, n, n, -1, -1, -1, imat,
494 $ nfail, nerrs, nout )
495
496
497
498
499 CALL cpot03( uplo, n, a, lda, ainv, lda, work, lda,
500 $ rwork, rcondc, result( 2 ) )
501 nt = 2
502 END IF
503
504
505
506
507 DO 110 k = 1, nt
508 IF( result( k ).GE.thresh ) THEN
509 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
510 $
CALL alahd( nout, path )
511 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
512 $ result( k )
513 nfail = nfail + 1
514 END IF
515 110 CONTINUE
516 nrun = nrun + nt
517
518
519
520
521 result( 3 ) = zero
522 stemp = zero
523
524 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) ) /
525 $ ( one-alpha )
526
527 IF( iuplo.EQ.1 ) THEN
528
529
530
531 k = n
532 120 CONTINUE
533 IF( k.LE.1 )
534 $ GO TO 130
535
536 IF( iwork( k ).GT.zero ) THEN
537
538
539
540
541 stemp =
clange(
'M', k-1, 1,
542 $ afac( ( k-1 )*lda+1 ), lda, rwork )
543 ELSE
544
545
546
547
548 stemp =
clange(
'M', k-2, 2,
549 $ afac( ( k-2 )*lda+1 ), lda, rwork )
550 k = k - 1
551
552 END IF
553
554
555
556 stemp = stemp - const + thresh
557 IF( stemp.GT.result( 3 ) )
558 $ result( 3 ) = stemp
559
560 k = k - 1
561
562 GO TO 120
563 130 CONTINUE
564
565 ELSE
566
567
568
569 k = 1
570 140 CONTINUE
571 IF( k.GE.n )
572 $ GO TO 150
573
574 IF( iwork( k ).GT.zero ) THEN
575
576
577
578
579 stemp =
clange(
'M', n-k, 1,
580 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
581 ELSE
582
583
584
585
586 stemp =
clange(
'M', n-k-1, 2,
587 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
588 k = k + 1
589
590 END IF
591
592
593
594 stemp = stemp - const + thresh
595 IF( stemp.GT.result( 3 ) )
596 $ result( 3 ) = stemp
597
598 k = k + 1
599
600 GO TO 140
601 150 CONTINUE
602 END IF
603
604
605
606
607
608
609 result( 4 ) = zero
610 stemp = zero
611
612 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
613 $ ( ( one + alpha ) / ( one - alpha ) )
614 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
615
616 IF( iuplo.EQ.1 ) THEN
617
618
619
620 k = n
621 160 CONTINUE
622 IF( k.LE.1 )
623 $ GO TO 170
624
625 IF( iwork( k ).LT.zero ) THEN
626
627
628
629
630
631 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
632 block( 1, 2 ) = afac( (k-1)*lda+k-1 )
633 block( 2, 1 ) = conjg( block( 1, 2 ) )
634 block( 2, 2 ) = afac( (k-1)*lda+k )
635
636 CALL cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
637 $ cdummy, 1, cdummy, 1,
638 $ work, 6, rwork( 3 ), info )
639
640
641 sing_max = rwork( 1 )
642 sing_min = rwork( 2 )
643
644 stemp = sing_max / sing_min
645
646
647
648 stemp = stemp - const + thresh
649 IF( stemp.GT.result( 4 ) )
650 $ result( 4 ) = stemp
651 k = k - 1
652
653 END IF
654
655 k = k - 1
656
657 GO TO 160
658 170 CONTINUE
659
660 ELSE
661
662
663
664 k = 1
665 180 CONTINUE
666 IF( k.GE.n )
667 $ GO TO 190
668
669 IF( iwork( k ).LT.zero ) THEN
670
671
672
673
674
675 block( 1, 1 ) = afac( ( k-1 )*lda+k )
676 block( 2, 1 ) = afac( ( k-1 )*lda+k+1 )
677 block( 1, 2 ) = conjg( block( 2, 1 ) )
678 block( 2, 2 ) = afac( k*lda+k+1 )
679
680 CALL cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
681 $ cdummy, 1, cdummy, 1,
682 $ work, 6, rwork(3), info )
683
684 sing_max = rwork( 1 )
685 sing_min = rwork( 2 )
686
687 stemp = sing_max / sing_min
688
689
690
691 stemp = stemp - const + thresh
692 IF( stemp.GT.result( 4 ) )
693 $ result( 4 ) = stemp
694 k = k + 1
695
696 END IF
697
698 k = k + 1
699
700 GO TO 180
701 190 CONTINUE
702 END IF
703
704
705
706
707 DO 200 k = 3, 4
708 IF( result( k ).GE.thresh ) THEN
709 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
710 $
CALL alahd( nout, path )
711 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
712 $ result( k )
713 nfail = nfail + 1
714 END IF
715 200 CONTINUE
716 nrun = nrun + 2
717
718
719
720
721 IF( inb.GT.1 )
722 $ GO TO 240
723
724
725
726 IF( trfcon ) THEN
727 rcondc = zero
728 GO TO 230
729 END IF
730
731
732
733 DO 220 irhs = 1, nns
734 nrhs = nsval( irhs )
735
736
737
738
739
740
741
742
743
744
745 srnamt = 'CLARHS'
746 CALL clarhs( matpath, xtype, uplo,
' ', n, n,
747 $ kl, ku, nrhs, a, lda, xact, lda,
748 $ b, lda, iseed, info )
749 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
750
751 srnamt = 'CHETRS_ROOK'
753 $ x, lda, info )
754
755
756
757 IF( info.NE.0 )
758 $
CALL alaerh( path,
'CHETRS_ROOK', info, 0,
759 $ uplo, n, n, -1, -1, nrhs, imat,
760 $ nfail, nerrs, nout )
761
762 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
763
764
765
766 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
767 $ lda, rwork, result( 5 ) )
768
769
770
771
772 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
773 $ result( 6 ) )
774
775
776
777
778 DO 210 k = 5, 6
779 IF( result( k ).GE.thresh ) THEN
780 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
781 $
CALL alahd( nout, path )
782 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
783 $ imat, k, result( k )
784 nfail = nfail + 1
785 END IF
786 210 CONTINUE
787 nrun = nrun + 2
788
789
790
791 220 CONTINUE
792
793
794
795
796 230 CONTINUE
797 anorm =
clanhe(
'1', uplo, n, a, lda, rwork )
798 srnamt = 'CHECON_ROOK'
799 CALL checon_rook( uplo, n, afac, lda, iwork, anorm,
800 $ rcond, work, info )
801
802
803
804 IF( info.NE.0 )
805 $
CALL alaerh( path,
'CHECON_ROOK', info, 0,
806 $ uplo, n, n, -1, -1, -1, imat,
807 $ nfail, nerrs, nout )
808
809
810
811 result( 7 ) =
sget06( rcond, rcondc )
812
813
814
815
816 IF( result( 7 ).GE.thresh ) THEN
817 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
818 $
CALL alahd( nout, path )
819 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
820 $ result( 7 )
821 nfail = nfail + 1
822 END IF
823 nrun = nrun + 1
824 240 CONTINUE
825
826 250 CONTINUE
827 260 CONTINUE
828 270 CONTINUE
829
830
831
832 CALL alasum( path, nout, nfail, nrun, nerrs )
833
834 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
835 $ i2, ', test ', i2, ', ratio =', g12.5 )
836 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
837 $ i2, ', test ', i2, ', ratio =', g12.5 )
838 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
839 $ ', test ', i2, ', ratio =', g12.5 )
840 RETURN
841
842
843
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
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 alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
subroutine alahd(iounit, path)
ALAHD
subroutine cerrhe(path, nunit)
CERRHE
subroutine cget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
CGET04
subroutine chet01_rook(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
CHET01_ROOK
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 cpot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CPOT02
subroutine cpot03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
CPOT03
subroutine cgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, rwork, info)
CGESVD computes the singular value decomposition (SVD) for GE matrices
subroutine checon_rook(uplo, n, a, lda, ipiv, anorm, rcond, work, info)
CHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obt...
subroutine chetrf_rook(uplo, n, a, lda, ipiv, work, lwork, info)
CHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bun...
subroutine chetri_rook(uplo, n, a, lda, ipiv, work, info)
CHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch...
subroutine chetrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
CHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using fac...
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 clanhe(norm, uplo, n, a, lda, work)
CLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
real function sget06(rcond, rcondc)
SGET06