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