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