172
173
174
175
176
177
178 LOGICAL TSTERR
179 INTEGER NMAX, NN, NNB, NNS, NOUT
180 DOUBLE PRECISION THRESH
181
182
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185 DOUBLE PRECISION RWORK( * )
186 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
187 $ WORK( * ), X( * ), XACT( * )
188
189
190
191
192
193 DOUBLE PRECISION ZERO, ONE
194 parameter( zero = 0.0d+0, one = 1.0d+0 )
195 DOUBLE PRECISION ONEHALF
196 parameter( onehalf = 0.5d+0 )
197 DOUBLE PRECISION EIGHT, SEVTEN
198 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
199 COMPLEX*16 CZERO
200 parameter( czero = ( 0.0d+0, 0.0d+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 DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
214 $ SING_MIN, RCOND, RCONDC, DTEMP
215
216
217 CHARACTER UPLOS( 2 )
218 INTEGER ISEED( 4 ), ISEEDY( 4 )
219 DOUBLE PRECISION RESULT( NTESTS )
220 COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 )
221
222
223 DOUBLE PRECISION ZLANGE, ZLANHE, DGET06
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 ) = 'Zomplex precision'
257 path( 2: 3 ) = 'HR'
258
259
260
261 matpath( 1: 1 ) = 'Zomplex 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 zerrhe( 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 zlatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
320 $ MODE, CNDNUM, DIST )
321
322
323
324 srnamt = 'ZLATMS'
325 CALL zlatms( 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,
'ZLATMS', 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 zlacpy( uplo, n, n, a, lda, afac, lda )
427
428
429
430
431
432
433 lwork = max( 2, nb )*lda
434 srnamt = 'ZHETRF_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,
'ZHETRF_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 zhet01_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 zlacpy( uplo, n, n, afac, lda, ainv, lda )
485 srnamt = 'ZHETRI_ROOK'
487 $ info )
488
489
490
491 IF( info.NE.0 )
492 $
CALL alaerh( path,
'ZHETRI_ROOK', info, -1,
493 $ uplo, n, n, -1, -1, -1, imat,
494 $ nfail, nerrs, nout )
495
496
497
498
499 CALL zpot03( 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 dtemp = 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 dtemp =
zlange(
'M', k-1, 1,
542 $ afac( ( k-1 )*lda+1 ), lda, rwork )
543 ELSE
544
545
546
547
548 dtemp =
zlange(
'M', k-2, 2,
549 $ afac( ( k-2 )*lda+1 ), lda, rwork )
550 k = k - 1
551
552 END IF
553
554
555
556 dtemp = dtemp - const + thresh
557 IF( dtemp.GT.result( 3 ) )
558 $ result( 3 ) = dtemp
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 dtemp =
zlange(
'M', n-k, 1,
580 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
581 ELSE
582
583
584
585
586 dtemp =
zlange(
'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 dtemp = dtemp - const + thresh
595 IF( dtemp.GT.result( 3 ) )
596 $ result( 3 ) = dtemp
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 dtemp = zero
611
612 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
613 $ ( ( one + alpha ) / ( one - alpha ) )
614 CALL zlacpy( 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 zgesvd(
'N',
'N', 2, 2, block, 2, rwork,
637 $ zdummy, 1, zdummy, 1,
638 $ work, 6, rwork( 3 ), info )
639
640
641 sing_max = rwork( 1 )
642 sing_min = rwork( 2 )
643
644 dtemp = sing_max / sing_min
645
646
647
648 dtemp = dtemp - const + thresh
649 IF( dtemp.GT.result( 4 ) )
650 $ result( 4 ) = dtemp
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 zgesvd(
'N',
'N', 2, 2, block, 2, rwork,
681 $ zdummy, 1, zdummy, 1,
682 $ work, 6, rwork(3), info )
683
684 sing_max = rwork( 1 )
685 sing_min = rwork( 2 )
686
687 dtemp = sing_max / sing_min
688
689
690
691 dtemp = dtemp - const + thresh
692 IF( dtemp.GT.result( 4 ) )
693 $ result( 4 ) = dtemp
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 = 'ZLARHS'
746 CALL zlarhs( matpath, xtype, uplo,
' ', n, n,
747 $ kl, ku, nrhs, a, lda, xact, lda,
748 $ b, lda, iseed, info )
749 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
750
751 srnamt = 'ZHETRS_ROOK'
753 $ x, lda, info )
754
755
756
757 IF( info.NE.0 )
758 $
CALL alaerh( path,
'ZHETRS_ROOK', info, 0,
759 $ uplo, n, n, -1, -1, nrhs, imat,
760 $ nfail, nerrs, nout )
761
762 CALL zlacpy(
'Full', n, nrhs, b, lda, work, lda )
763
764
765
766 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
767 $ lda, rwork, result( 5 ) )
768
769
770
771
772 CALL zget04( 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 =
zlanhe(
'1', uplo, n, a, lda, rwork )
798 srnamt = 'ZHECON_ROOK'
799 CALL zhecon_rook( uplo, n, afac, lda, iwork, anorm,
800 $ rcond, work, info )
801
802
803
804 IF( info.NE.0 )
805 $
CALL alaerh( path,
'ZHECON_ROOK', info, 0,
806 $ uplo, n, n, -1, -1, -1, imat,
807 $ nfail, nerrs, nout )
808
809
810
811 result( 7 ) =
dget06( 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 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 zgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, rwork, info)
ZGESVD computes the singular value decomposition (SVD) for GE matrices
subroutine zhecon_rook(uplo, n, a, lda, ipiv, anorm, rcond, work, info)
ZHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obt...
subroutine zhetrf_rook(uplo, n, a, lda, ipiv, work, lwork, info)
ZHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bun...
subroutine zhetri_rook(uplo, n, a, lda, ipiv, work, info)
ZHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch...
subroutine zhetrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
ZHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using fac...
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 zlanhe(norm, uplo, n, a, lda, work)
ZLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
subroutine zerrhe(path, nunit)
ZERRHE
subroutine zget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
ZGET04
subroutine zhet01_rook(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
ZHET01_ROOK
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 zpot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZPOT02
subroutine zpot03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
ZPOT03