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