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 = 11 )
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, CLANSY, SGET06
225
226
231
232
233 INTRINSIC 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 ) = 'SR'
258
259
260
261 matpath( 1: 1 ) = 'Complex precision'
262 matpath( 2: 3 ) = 'SY'
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 cerrsy( 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 IF( imat.NE.ntypes ) THEN
317
318
319
320
321 CALL clatb4( matpath, imat, n, n,
TYPE, KL, KU, ANORM,
322 $ MODE, CNDNUM, DIST )
323
324
325
326 srnamt = 'CLATMS'
327 CALL clatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
328 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
329 $ WORK, INFO )
330
331
332
333 IF( info.NE.0 ) THEN
334 CALL alaerh( path,
'CLATMS', info, 0, uplo, n, n,
335 $ -1, -1, -1, imat, nfail, nerrs, nout )
336
337
338
339 GO TO 250
340 END IF
341
342
343
344
345
346 IF( zerot ) THEN
347 IF( imat.EQ.3 ) THEN
348 izero = 1
349 ELSE IF( imat.EQ.4 ) THEN
350 izero = n
351 ELSE
352 izero = n / 2 + 1
353 END IF
354
355 IF( imat.LT.6 ) THEN
356
357
358
359 IF( iuplo.EQ.1 ) THEN
360 ioff = ( izero-1 )*lda
361 DO 20 i = 1, izero - 1
362 a( ioff+i ) = czero
363 20 CONTINUE
364 ioff = ioff + izero
365 DO 30 i = izero, n
366 a( ioff ) = czero
367 ioff = ioff + lda
368 30 CONTINUE
369 ELSE
370 ioff = izero
371 DO 40 i = 1, izero - 1
372 a( ioff ) = czero
373 ioff = ioff + lda
374 40 CONTINUE
375 ioff = ioff - izero
376 DO 50 i = izero, n
377 a( ioff+i ) = czero
378 50 CONTINUE
379 END IF
380 ELSE
381 IF( iuplo.EQ.1 ) THEN
382
383
384
385 ioff = 0
386 DO 70 j = 1, n
387 i2 = min( j, izero )
388 DO 60 i = 1, i2
389 a( ioff+i ) = czero
390 60 CONTINUE
391 ioff = ioff + lda
392 70 CONTINUE
393 ELSE
394
395
396
397 ioff = 0
398 DO 90 j = 1, n
399 i1 = max( j, izero )
400 DO 80 i = i1, n
401 a( ioff+i ) = czero
402 80 CONTINUE
403 ioff = ioff + lda
404 90 CONTINUE
405 END IF
406 END IF
407 ELSE
408 izero = 0
409 END IF
410
411 ELSE
412
413
414
415
416
417 CALL clatsy( uplo, n, a, lda, iseed )
418
419 END IF
420
421
422
423
424
425
426 DO 240 inb = 1, nnb
427
428
429
430
431 nb = nbval( inb )
433
434
435
436
437
438 CALL clacpy( uplo, n, n, a, lda, afac, lda )
439
440
441
442
443
444
445 lwork = max( 2, nb )*lda
446 srnamt = 'CSYTRF_ROOK'
448 $ lwork, info )
449
450
451
452
453 k = izero
454 IF( k.GT.0 ) THEN
455 100 CONTINUE
456 IF( iwork( k ).LT.0 ) THEN
457 IF( iwork( k ).NE.-k ) THEN
458 k = -iwork( k )
459 GO TO 100
460 END IF
461 ELSE IF( iwork( k ).NE.k ) THEN
462 k = iwork( k )
463 GO TO 100
464 END IF
465 END IF
466
467
468
469 IF( info.NE.k)
470 $
CALL alaerh( path,
'CSYTRF_ROOK', info, k,
471 $ uplo, n, n, -1, -1, nb, imat,
472 $ nfail, nerrs, nout )
473
474
475
476 IF( info.NE.0 ) THEN
477 trfcon = .true.
478 ELSE
479 trfcon = .false.
480 END IF
481
482
483
484
485 CALL csyt01_rook( uplo, n, a, lda, afac, lda, iwork,
486 $ ainv, lda, rwork, result( 1 ) )
487 nt = 1
488
489
490
491
492
493
494
495 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
496 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
497 srnamt = 'CSYTRI_ROOK'
499 $ info )
500
501
502
503 IF( info.NE.0 )
504 $
CALL alaerh( path,
'CSYTRI_ROOK', info, -1,
505 $ uplo, n, n, -1, -1, -1, imat,
506 $ nfail, nerrs, nout )
507
508
509
510
511 CALL csyt03( 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
627 IF( iuplo.EQ.1 ) THEN
628
629
630
631 k = n
632 160 CONTINUE
633 IF( k.LE.1 )
634 $ GO TO 170
635
636 IF( iwork( k ).LT.zero ) THEN
637
638
639
640
641
642 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
643 block( 1, 2 ) = afac( (k-1)*lda+k-1 )
644 block( 2, 1 ) = block( 1, 2 )
645 block( 2, 2 ) = afac( (k-1)*lda+k )
646
647 CALL cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
648 $ cdummy, 1, cdummy, 1,
649 $ work, 6, rwork( 3 ), info )
650
651
652 sing_max = rwork( 1 )
653 sing_min = rwork( 2 )
654
655 stemp = sing_max / sing_min
656
657
658
659 stemp = stemp - const + thresh
660 IF( stemp.GT.result( 4 ) )
661 $ result( 4 ) = stemp
662 k = k - 1
663
664 END IF
665
666 k = k - 1
667
668 GO TO 160
669 170 CONTINUE
670
671 ELSE
672
673
674
675 k = 1
676 180 CONTINUE
677 IF( k.GE.n )
678 $ GO TO 190
679
680 IF( iwork( k ).LT.zero ) THEN
681
682
683
684
685
686 block( 1, 1 ) = afac( ( k-1 )*lda+k )
687 block( 2, 1 ) = afac( ( k-1 )*lda+k+1 )
688 block( 1, 2 ) = block( 2, 1 )
689 block( 2, 2 ) = afac( k*lda+k+1 )
690
691 CALL cgesvd(
'N',
'N', 2, 2, block, 2, rwork,
692 $ cdummy, 1, cdummy, 1,
693 $ work, 6, rwork(3), info )
694
695 sing_max = rwork( 1 )
696 sing_min = rwork( 2 )
697
698 stemp = sing_max / sing_min
699
700
701
702 stemp = stemp - const + thresh
703 IF( stemp.GT.result( 4 ) )
704 $ result( 4 ) = stemp
705 k = k + 1
706
707 END IF
708
709 k = k + 1
710
711 GO TO 180
712 190 CONTINUE
713 END IF
714
715
716
717
718 DO 200 k = 3, 4
719 IF( result( k ).GE.thresh ) THEN
720 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
721 $
CALL alahd( nout, path )
722 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
723 $ result( k )
724 nfail = nfail + 1
725 END IF
726 200 CONTINUE
727 nrun = nrun + 2
728
729
730
731
732 IF( inb.GT.1 )
733 $ GO TO 240
734
735
736
737 IF( trfcon ) THEN
738 rcondc = zero
739 GO TO 230
740 END IF
741
742
743
744 DO 220 irhs = 1, nns
745 nrhs = nsval( irhs )
746
747
748
749
750
751
752
753 srnamt = 'CLARHS'
754 CALL clarhs( matpath, xtype, uplo,
' ', n, n,
755 $ kl, ku, nrhs, a, lda, xact, lda,
756 $ b, lda, iseed, info )
757 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
758
759 srnamt = 'CSYTRS_ROOK'
761 $ x, lda, info )
762
763
764
765 IF( info.NE.0 )
766 $
CALL alaerh( path,
'CSYTRS_ROOK', info, 0,
767 $ uplo, n, n, -1, -1, nrhs, imat,
768 $ nfail, nerrs, nout )
769
770 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
771
772
773
774 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
775 $ lda, rwork, result( 5 ) )
776
777
778
779
780 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
781 $ result( 6 ) )
782
783
784
785
786 DO 210 k = 5, 6
787 IF( result( k ).GE.thresh ) THEN
788 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
789 $
CALL alahd( nout, path )
790 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
791 $ imat, k, result( k )
792 nfail = nfail + 1
793 END IF
794 210 CONTINUE
795 nrun = nrun + 2
796
797
798
799 220 CONTINUE
800
801
802
803
804 230 CONTINUE
805 anorm =
clansy(
'1', uplo, n, a, lda, rwork )
806 srnamt = 'CSYCON_ROOK'
807 CALL csycon_rook( uplo, n, afac, lda, iwork, anorm,
808 $ rcond, work, info )
809
810
811
812 IF( info.NE.0 )
813 $
CALL alaerh( path,
'CSYCON_ROOK', info, 0,
814 $ uplo, n, n, -1, -1, -1, imat,
815 $ nfail, nerrs, nout )
816
817
818
819 result( 7 ) =
sget06( rcond, rcondc )
820
821
822
823
824 IF( result( 7 ).GE.thresh ) THEN
825 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
826 $
CALL alahd( nout, path )
827 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
828 $ result( 7 )
829 nfail = nfail + 1
830 END IF
831 nrun = nrun + 1
832 240 CONTINUE
833
834 250 CONTINUE
835 260 CONTINUE
836 270 CONTINUE
837
838
839
840 CALL alasum( path, nout, nfail, nrun, nerrs )
841
842 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
843 $ i2, ', test ', i2, ', ratio =', g12.5 )
844 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
845 $ i2, ', test(', i2, ') =', g12.5 )
846 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
847 $ ', test(', i2, ') =', g12.5 )
848 RETURN
849
850
851
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_rook(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
CSYT01_ROOK
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_rook(uplo, n, a, lda, ipiv, anorm, rcond, work, info)
CSYCON_ROOK
subroutine csytrf_rook(uplo, n, a, lda, ipiv, work, lwork, info)
CSYTRF_ROOK
subroutine csytri_rook(uplo, n, a, lda, ipiv, work, info)
CSYTRI_ROOK
subroutine csytrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
CSYTRS_ROOK
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