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 = 11 )
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 )
225 REAL RESULT( NTESTS )
226 COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
227
228
229 REAL CLANGE, CLANSY, SGET06
231
232
237
238
239 INTRINSIC 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 ) = 'SK'
264
265
266
267 matpath( 1: 1 ) = 'Complex precision'
268 matpath( 2: 3 ) = 'SY'
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 cerrsy( 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 IF( imat.NE.ntypes ) THEN
323
324
325
326
327 CALL clatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
328 $ MODE, CNDNUM, DIST )
329
330
331
332 srnamt = 'CLATMS'
333 CALL clatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
334 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
335 $ WORK, INFO )
336
337
338
339 IF( info.NE.0 ) THEN
340 CALL alaerh( path,
'CLATMS', info, 0, uplo, n, n,
341 $ -1, -1, -1, imat, nfail, nerrs, nout )
342
343
344
345 GO TO 250
346 END IF
347
348
349
350
351
352 IF( zerot ) THEN
353 IF( imat.EQ.3 ) THEN
354 izero = 1
355 ELSE IF( imat.EQ.4 ) THEN
356 izero = n
357 ELSE
358 izero = n / 2 + 1
359 END IF
360
361 IF( imat.LT.6 ) THEN
362
363
364
365 IF( iuplo.EQ.1 ) THEN
366 ioff = ( izero-1 )*lda
367 DO 20 i = 1, izero - 1
368 a( ioff+i ) = czero
369 20 CONTINUE
370 ioff = ioff + izero
371 DO 30 i = izero, n
372 a( ioff ) = czero
373 ioff = ioff + lda
374 30 CONTINUE
375 ELSE
376 ioff = izero
377 DO 40 i = 1, izero - 1
378 a( ioff ) = czero
379 ioff = ioff + lda
380 40 CONTINUE
381 ioff = ioff - izero
382 DO 50 i = izero, n
383 a( ioff+i ) = czero
384 50 CONTINUE
385 END IF
386 ELSE
387 IF( iuplo.EQ.1 ) THEN
388
389
390
391 ioff = 0
392 DO 70 j = 1, n
393 i2 = min( j, izero )
394 DO 60 i = 1, i2
395 a( ioff+i ) = czero
396 60 CONTINUE
397 ioff = ioff + lda
398 70 CONTINUE
399 ELSE
400
401
402
403 ioff = 0
404 DO 90 j = 1, n
405 i1 = max( j, izero )
406 DO 80 i = i1, n
407 a( ioff+i ) = czero
408 80 CONTINUE
409 ioff = ioff + lda
410 90 CONTINUE
411 END IF
412 END IF
413 ELSE
414 izero = 0
415 END IF
416
417 ELSE
418
419
420
421
422
423 CALL clatsy( uplo, n, a, lda, iseed )
424
425 END IF
426
427
428
429
430
431
432 DO 240 inb = 1, nnb
433
434
435
436
437 nb = nbval( inb )
439
440
441
442
443
444 CALL clacpy( uplo, n, n, a, lda, afac, lda )
445
446
447
448
449
450
451 lwork = max( 2, nb )*lda
452 srnamt = 'CSYTRF_RK'
453 CALL csytrf_rk( uplo, n, afac, lda, e, iwork, ainv,
454 $ lwork, info )
455
456
457
458
459 k = izero
460 IF( k.GT.0 ) THEN
461 100 CONTINUE
462 IF( iwork( k ).LT.0 ) THEN
463 IF( iwork( k ).NE.-k ) THEN
464 k = -iwork( k )
465 GO TO 100
466 END IF
467 ELSE IF( iwork( k ).NE.k ) THEN
468 k = iwork( k )
469 GO TO 100
470 END IF
471 END IF
472
473
474
475 IF( info.NE.k)
476 $
CALL alaerh( path,
'CSYTRF_RK', info, k,
477 $ uplo, n, n, -1, -1, nb, imat,
478 $ nfail, nerrs, nout )
479
480
481
482 IF( info.NE.0 ) THEN
483 trfcon = .true.
484 ELSE
485 trfcon = .false.
486 END IF
487
488
489
490
491 CALL csyt01_3( uplo, n, a, lda, afac, lda, e, iwork,
492 $ ainv, lda, rwork, result( 1 ) )
493 nt = 1
494
495
496
497
498
499
500
501 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
502 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
503 srnamt = 'CSYTRI_3'
504
505
506
507
508
509 lwork = (n+nb+1)*(nb+3)
510 CALL csytri_3( uplo, n, ainv, lda, e, iwork, work,
511 $ lwork, info )
512
513
514
515 IF( info.NE.0 )
516 $
CALL alaerh( path,
'CSYTRI_3', info, -1,
517 $ uplo, n, n, -1, -1, -1, imat,
518 $ nfail, nerrs, nout )
519
520
521
522
523 CALL csyt03( uplo, n, a, lda, ainv, lda, work, lda,
524 $ rwork, rcondc, result( 2 ) )
525 nt = 2
526 END IF
527
528
529
530
531 DO 110 k = 1, nt
532 IF( result( k ).GE.thresh ) THEN
533 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
534 $
CALL alahd( nout, path )
535 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
536 $ result( k )
537 nfail = nfail + 1
538 END IF
539 110 CONTINUE
540 nrun = nrun + nt
541
542
543
544
545 result( 3 ) = zero
546 stemp = zero
547
548 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) ) /
549 $ ( one-alpha )
550
551 IF( iuplo.EQ.1 ) THEN
552
553
554
555 k = n
556 120 CONTINUE
557 IF( k.LE.1 )
558 $ GO TO 130
559
560 IF( iwork( k ).GT.zero ) THEN
561
562
563
564
565 stemp =
clange(
'M', k-1, 1,
566 $ afac( ( k-1 )*lda+1 ), lda, rwork )
567 ELSE
568
569
570
571
572 stemp =
clange(
'M', k-2, 2,
573 $ afac( ( k-2 )*lda+1 ), lda, rwork )
574 k = k - 1
575
576 END IF
577
578
579
580 stemp = stemp - const + thresh
581 IF( stemp.GT.result( 3 ) )
582 $ result( 3 ) = stemp
583
584 k = k - 1
585
586 GO TO 120
587 130 CONTINUE
588
589 ELSE
590
591
592
593 k = 1
594 140 CONTINUE
595 IF( k.GE.n )
596 $ GO TO 150
597
598 IF( iwork( k ).GT.zero ) THEN
599
600
601
602
603 stemp =
clange(
'M', n-k, 1,
604 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
605 ELSE
606
607
608
609
610 stemp =
clange(
'M', n-k-1, 2,
611 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
612 k = k + 1
613
614 END IF
615
616
617
618 stemp = stemp - const + thresh
619 IF( stemp.GT.result( 3 ) )
620 $ result( 3 ) = stemp
621
622 k = k + 1
623
624 GO TO 140
625 150 CONTINUE
626 END IF
627
628
629
630
631
632
633 result( 4 ) = zero
634 stemp = zero
635
636 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
637 $ ( ( one + alpha ) / ( one - alpha ) )
638
639 IF( iuplo.EQ.1 ) THEN
640
641
642
643 k = n
644 160 CONTINUE
645 IF( k.LE.1 )
646 $ GO TO 170
647
648 IF( iwork( k ).LT.zero ) THEN
649
650
651
652
653
654 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
655 block( 1, 2 ) = e( k )
656 block( 2, 1 ) = block( 1, 2 )
657 block( 2, 2 ) = afac( (k-1)*lda+k )
658
659 CALL cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
660 $ cdummy, 1, cdummy, 1,
661 $ work, 6, rwork( 3 ), info )
662
663
664 sing_max = rwork( 1 )
665 sing_min = rwork( 2 )
666
667 stemp = sing_max / sing_min
668
669
670
671 stemp = stemp - const + thresh
672 IF( stemp.GT.result( 4 ) )
673 $ result( 4 ) = stemp
674 k = k - 1
675
676 END IF
677
678 k = k - 1
679
680 GO TO 160
681 170 CONTINUE
682
683 ELSE
684
685
686
687 k = 1
688 180 CONTINUE
689 IF( k.GE.n )
690 $ GO TO 190
691
692 IF( iwork( k ).LT.zero ) THEN
693
694
695
696
697
698 block( 1, 1 ) = afac( ( k-1 )*lda+k )
699 block( 2, 1 ) = e( k )
700 block( 1, 2 ) = block( 2, 1 )
701 block( 2, 2 ) = afac( k*lda+k+1 )
702
703 CALL cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
704 $ cdummy, 1, cdummy, 1,
705 $ work, 6, rwork(3), info )
706
707 sing_max = rwork( 1 )
708 sing_min = rwork( 2 )
709
710 stemp = sing_max / sing_min
711
712
713
714 stemp = stemp - const + thresh
715 IF( stemp.GT.result( 4 ) )
716 $ result( 4 ) = stemp
717 k = k + 1
718
719 END IF
720
721 k = k + 1
722
723 GO TO 180
724 190 CONTINUE
725 END IF
726
727
728
729
730 DO 200 k = 3, 4
731 IF( result( k ).GE.thresh ) THEN
732 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
733 $
CALL alahd( nout, path )
734 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
735 $ result( k )
736 nfail = nfail + 1
737 END IF
738 200 CONTINUE
739 nrun = nrun + 2
740
741
742
743
744 IF( inb.GT.1 )
745 $ GO TO 240
746
747
748
749 IF( trfcon ) THEN
750 rcondc = zero
751 GO TO 230
752 END IF
753
754
755
756 DO 220 irhs = 1, nns
757 nrhs = nsval( irhs )
758
759
760
761
762
763
764
765 srnamt = 'CLARHS'
766 CALL clarhs( matpath, xtype, uplo,
' ', n, n,
767 $ kl, ku, nrhs, a, lda, xact, lda,
768 $ b, lda, iseed, info )
769 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
770
771 srnamt = 'CSYTRS_3'
772 CALL csytrs_3( uplo, n, nrhs, afac, lda, e, iwork,
773 $ x, lda, info )
774
775
776
777 IF( info.NE.0 )
778 $
CALL alaerh( path,
'CSYTRS_3', info, 0,
779 $ uplo, n, n, -1, -1, nrhs, imat,
780 $ nfail, nerrs, nout )
781
782 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
783
784
785
786 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
787 $ lda, rwork, result( 5 ) )
788
789
790
791
792 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
793 $ result( 6 ) )
794
795
796
797
798 DO 210 k = 5, 6
799 IF( result( k ).GE.thresh ) THEN
800 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
801 $
CALL alahd( nout, path )
802 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
803 $ imat, k, result( k )
804 nfail = nfail + 1
805 END IF
806 210 CONTINUE
807 nrun = nrun + 2
808
809
810
811 220 CONTINUE
812
813
814
815
816 230 CONTINUE
817 anorm =
clansy(
'1', uplo, n, a, lda, rwork )
818 srnamt = 'CSYCON_3'
819 CALL csycon_3( uplo, n, afac, lda, e, iwork, anorm,
820 $ rcond, work, info )
821
822
823
824 IF( info.NE.0 )
825 $
CALL alaerh( path,
'CSYCON_3', info, 0,
826 $ uplo, n, n, -1, -1, -1, imat,
827 $ nfail, nerrs, nout )
828
829
830
831 result( 7 ) =
sget06( rcond, rcondc )
832
833
834
835
836 IF( result( 7 ).GE.thresh ) THEN
837 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
838 $
CALL alahd( nout, path )
839 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
840 $ result( 7 )
841 nfail = nfail + 1
842 END IF
843 nrun = nrun + 1
844 240 CONTINUE
845
846 250 CONTINUE
847 260 CONTINUE
848 270 CONTINUE
849
850
851
852 CALL alasum( path, nout, nfail, nrun, nerrs )
853
854 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
855 $ i2, ', test ', i2, ', ratio =', g12.5 )
856 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
857 $ i2, ', test(', i2, ') =', g12.5 )
858 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
859 $ ', test(', i2, ') =', g12.5 )
860 RETURN
861
862
863
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 cerrsy(path, nunit)
CERRSY
subroutine cget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
CGET04
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 clatsy(uplo, n, x, ldx, iseed)
CLATSY
subroutine csyt01_3(uplo, n, a, lda, afac, ldafac, e, ipiv, c, ldc, rwork, resid)
CSYT01_3
subroutine csyt02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CSYT02
subroutine csyt03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
CSYT03
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 csycon_3(uplo, n, a, lda, e, ipiv, anorm, rcond, work, info)
CSYCON_3
subroutine csytrf_rk(uplo, n, a, lda, e, ipiv, work, lwork, info)
CSYTRF_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch...
subroutine csytri_3(uplo, n, a, lda, e, ipiv, work, lwork, info)
CSYTRI_3
subroutine csytrs_3(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info)
CSYTRS_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 clansy(norm, uplo, n, a, lda, work)
CLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
real function sget06(rcond, rcondc)
SGET06