test/zblat2.f

   1       PROGRAM ZBLAT2
   2 *
   3 *  Test program for the COMPLEX*16       Level 2 Blas.
   4 *
   5 *  The program must be driven by a short data file. The first 18 records
   6 *  of the file are read using list-directed input, the last 17 records
   7 *  are read using the format ( A6, L2 ). An annotated example of a data
   8 *  file can be obtained by deleting the first 3 characters from the
   9 *  following 35 lines:
  10 *  'ZBLAT2.SUMM'     NAME OF SUMMARY OUTPUT FILE
  11 *  6                 UNIT NUMBER OF SUMMARY FILE
  12 *  'CBLA2T.SNAP'     NAME OF SNAPSHOT OUTPUT FILE
  13 *  -1                UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
  14 *  F        LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
  15 *  F        LOGICAL FLAG, T TO STOP ON FAILURES.
  16 *  T        LOGICAL FLAG, T TO TEST ERROR EXITS.
  17 *  16.0     THRESHOLD VALUE OF TEST RATIO
  18 *  6                 NUMBER OF VALUES OF N
  19 *  0 1 2 3 5 9       VALUES OF N
  20 *  4                 NUMBER OF VALUES OF K
  21 *  0 1 2 4           VALUES OF K
  22 *  4                 NUMBER OF VALUES OF INCX AND INCY
  23 *  1 2 -1 -2         VALUES OF INCX AND INCY
  24 *  3                 NUMBER OF VALUES OF ALPHA
  25 *  (0.0,0.0) (1.0,0.0) (0.7,-0.9)       VALUES OF ALPHA
  26 *  3                 NUMBER OF VALUES OF BETA
  27 *  (0.0,0.0) (1.0,0.0) (1.3,-1.1)       VALUES OF BETA
  28 *  ZGEMV  T PUT F FOR NO TEST. SAME COLUMNS.
  29 *  ZGBMV  T PUT F FOR NO TEST. SAME COLUMNS.
  30 *  ZHEMV  T PUT F FOR NO TEST. SAME COLUMNS.
  31 *  ZHBMV  T PUT F FOR NO TEST. SAME COLUMNS.
  32 *  ZHPMV  T PUT F FOR NO TEST. SAME COLUMNS.
  33 *  ZTRMV  T PUT F FOR NO TEST. SAME COLUMNS.
  34 *  ZTBMV  T PUT F FOR NO TEST. SAME COLUMNS.
  35 *  ZTPMV  T PUT F FOR NO TEST. SAME COLUMNS.
  36 *  ZTRSV  T PUT F FOR NO TEST. SAME COLUMNS.
  37 *  ZTBSV  T PUT F FOR NO TEST. SAME COLUMNS.
  38 *  ZTPSV  T PUT F FOR NO TEST. SAME COLUMNS.
  39 *  ZGERC  T PUT F FOR NO TEST. SAME COLUMNS.
  40 *  ZGERU  T PUT F FOR NO TEST. SAME COLUMNS.
  41 *  ZHER   T PUT F FOR NO TEST. SAME COLUMNS.
  42 *  ZHPR   T PUT F FOR NO TEST. SAME COLUMNS.
  43 *  ZHER2  T PUT F FOR NO TEST. SAME COLUMNS.
  44 *  ZHPR2  T PUT F FOR NO TEST. SAME COLUMNS.
  45 *
  46 *     See:
  47 *
  48 *        Dongarra J. J., Du Croz J. J., Hammarling S.  and Hanson R. J..
  49 *        An  extended  set of Fortran  Basic Linear Algebra Subprograms.
  50 *
  51 *        Technical  Memoranda  Nos. 41 (revision 3) and 81,  Mathematics
  52 *        and  Computer Science  Division,  Argonne  National Laboratory,
  53 *        9700 South Cass Avenue, Argonne, Illinois 60439, US.
  54 *
  55 *        Or
  56 *
  57 *        NAG  Technical Reports TR3/87 and TR4/87,  Numerical Algorithms
  58 *        Group  Ltd.,  NAG  Central  Office,  256  Banbury  Road, Oxford
  59 *        OX2 7DE, UK,  and  Numerical Algorithms Group Inc.,  1101  31st
  60 *        Street,  Suite 100,  Downers Grove,  Illinois 60515-1263,  USA.
  61 *
  62 *
  63 *  -- Written on 10-August-1987.
  64 *     Richard Hanson, Sandia National Labs.
  65 *     Jeremy Du Croz, NAG Central Office.
  66 *
  67 *     .. Parameters ..
  68       INTEGER            NIN
  69       PARAMETER          ( NIN = 5 )
  70       INTEGER            NSUBS
  71       PARAMETER          ( NSUBS = 17 )
  72       COMPLEX*16         ZERO, ONE
  73       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
  74      $                   ONE = ( 1.0D0, 0.0D0 ) )
  75       DOUBLE PRECISION   RZERO, RHALF, RONE
  76       PARAMETER          ( RZERO = 0.0D0, RHALF = 0.5D0, RONE = 1.0D0 )
  77       INTEGER            NMAX, INCMAX
  78       PARAMETER          ( NMAX = 65, INCMAX = 2 )
  79       INTEGER            NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
  80       PARAMETER          ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7,
  81      $                   NALMAX = 7, NBEMAX = 7 )
  82 *     .. Local Scalars ..
  83       DOUBLE PRECISION   EPS, ERR, THRESH
  84       INTEGER            I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
  85      $                   NOUT, NTRA
  86       LOGICAL            FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
  87      $                   TSTERR
  88       CHARACTER*1        TRANS
  89       CHARACTER*6        SNAMET
  90       CHARACTER*32       SNAPS, SUMMRY
  91 *     .. Local Arrays ..
  92       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ),
  93      $                   ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ),
  94      $                   X( NMAX ), XS( NMAX*INCMAX ),
  95      $                   XX( NMAX*INCMAX ), Y( NMAX ),
  96      $                   YS( NMAX*INCMAX ), YT( NMAX ),
  97      $                   YY( NMAX*INCMAX ), Z( 2*NMAX )
  98       DOUBLE PRECISION   G( NMAX )
  99       INTEGER            IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )
 100       LOGICAL            LTEST( NSUBS )
 101       CHARACTER*6        SNAMES( NSUBS )
 102 *     .. External Functions ..
 103       DOUBLE PRECISION   DDIFF
 104       LOGICAL            LZE
 105       EXTERNAL           DDIFF, LZE
 106 *     .. External Subroutines ..
 107       EXTERNAL           ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHK6,
 108      $                   ZCHKE, ZMVCH
 109 *     .. Intrinsic Functions ..
 110       INTRINSIC          ABS, MAX, MIN
 111 *     .. Scalars in Common ..
 112       INTEGER            INFOT, NOUTC
 113       LOGICAL            LERR, OK
 114       CHARACTER*6        SRNAMT
 115 *     .. Common blocks ..
 116       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
 117       COMMON             /SRNAMC/SRNAMT
 118 *     .. Data statements ..
 119       DATA               SNAMES/'ZGEMV ', 'ZGBMV ', 'ZHEMV ', 'ZHBMV ',
 120      $                   'ZHPMV ', 'ZTRMV ', 'ZTBMV ', 'ZTPMV ',
 121      $                   'ZTRSV ', 'ZTBSV ', 'ZTPSV ', 'ZGERC ',
 122      $                   'ZGERU ', 'ZHER  ', 'ZHPR  ', 'ZHER2 ',
 123      $                   'ZHPR2 '/
 124 *     .. Executable Statements ..
 125 *
 126 *     Read name and unit number for summary output file and open file.
 127 *
 128       READ( NIN, FMT = * )SUMMRY
 129       READ( NIN, FMT = * )NOUT
 130       OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
 131       NOUTC = NOUT
 132 *
 133 *     Read name and unit number for snapshot output file and open file.
 134 *
 135       READ( NIN, FMT = * )SNAPS
 136       READ( NIN, FMT = * )NTRA
 137       TRACE = NTRA.GE.0
 138       IF( TRACE )THEN
 139          OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
 140       END IF
 141 *     Read the flag that directs rewinding of the snapshot file.
 142       READ( NIN, FMT = * )REWI
 143       REWI = REWI.AND.TRACE
 144 *     Read the flag that directs stopping on any failure.
 145       READ( NIN, FMT = * )SFATAL
 146 *     Read the flag that indicates whether error exits are to be tested.
 147       READ( NIN, FMT = * )TSTERR
 148 *     Read the threshold value of the test ratio
 149       READ( NIN, FMT = * )THRESH
 150 *
 151 *     Read and check the parameter values for the tests.
 152 *
 153 *     Values of N
 154       READ( NIN, FMT = * )NIDIM
 155       IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
 156          WRITE( NOUT, FMT = 9997 )'N', NIDMAX
 157          GO TO 230
 158       END IF
 159       READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
 160       DO 10 I = 1, NIDIM
 161          IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
 162             WRITE( NOUT, FMT = 9996 )NMAX
 163             GO TO 230
 164          END IF
 165    10 CONTINUE
 166 *     Values of K
 167       READ( NIN, FMT = * )NKB
 168       IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
 169          WRITE( NOUT, FMT = 9997 )'K', NKBMAX
 170          GO TO 230
 171       END IF
 172       READ( NIN, FMT = * )( KB( I ), I = 1, NKB )
 173       DO 20 I = 1, NKB
 174          IF( KB( I ).LT.0 )THEN
 175             WRITE( NOUT, FMT = 9995 )
 176             GO TO 230
 177          END IF
 178    20 CONTINUE
 179 *     Values of INCX and INCY
 180       READ( NIN, FMT = * )NINC
 181       IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN
 182          WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX
 183          GO TO 230
 184       END IF
 185       READ( NIN, FMT = * )( INC( I ), I = 1, NINC )
 186       DO 30 I = 1, NINC
 187          IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
 188             WRITE( NOUT, FMT = 9994 )INCMAX
 189             GO TO 230
 190          END IF
 191    30 CONTINUE
 192 *     Values of ALPHA
 193       READ( NIN, FMT = * )NALF
 194       IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
 195          WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
 196          GO TO 230
 197       END IF
 198       READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
 199 *     Values of BETA
 200       READ( NIN, FMT = * )NBET
 201       IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
 202          WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
 203          GO TO 230
 204       END IF
 205       READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
 206 *
 207 *     Report values of parameters.
 208 *
 209       WRITE( NOUT, FMT = 9993 )
 210       WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM )
 211       WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB )
 212       WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC )
 213       WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF )
 214       WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET )
 215       IF( .NOT.TSTERR )THEN
 216          WRITE( NOUT, FMT = * )
 217          WRITE( NOUT, FMT = 9980 )
 218       END IF
 219       WRITE( NOUT, FMT = * )
 220       WRITE( NOUT, FMT = 9999 )THRESH
 221       WRITE( NOUT, FMT = * )
 222 *
 223 *     Read names of subroutines and flags which indicate
 224 *     whether they are to be tested.
 225 *
 226       DO 40 I = 1, NSUBS
 227          LTEST( I ) = .FALSE.
 228    40 CONTINUE
 229    50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT
 230       DO 60 I = 1, NSUBS
 231          IF( SNAMET.EQ.SNAMES( I ) )
 232      $      GO TO 70
 233    60 CONTINUE
 234       WRITE( NOUT, FMT = 9986 )SNAMET
 235       STOP
 236    70 LTEST( I ) = LTESTT
 237       GO TO 50
 238 *
 239    80 CONTINUE
 240       CLOSE ( NIN )
 241 *
 242 *     Compute EPS (the machine precision).
 243 *
 244       EPS = RONE
 245    90 CONTINUE
 246       IF( DDIFF( RONE + EPS, RONE ).EQ.RZERO )
 247      $   GO TO 100
 248       EPS = RHALF*EPS
 249       GO TO 90
 250   100 CONTINUE
 251       EPS = EPS + EPS
 252       WRITE( NOUT, FMT = 9998 )EPS
 253 *
 254 *     Check the reliability of ZMVCH using exact data.
 255 *
 256       N = MIN( 32, NMAX )
 257       DO 120 J = 1, N
 258          DO 110 I = 1, N
 259             A( I, J ) = MAX( I - J + 1, 0 )
 260   110    CONTINUE
 261          X( J ) = J
 262          Y( J ) = ZERO
 263   120 CONTINUE
 264       DO 130 J = 1, N
 265          YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
 266   130 CONTINUE
 267 *     YY holds the exact result. On exit from ZMVCH YT holds
 268 *     the result computed by ZMVCH.
 269       TRANS = 'N'
 270       CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
 271      $            YY, EPS, ERR, FATAL, NOUT, .TRUE. )
 272       SAME = LZE( YY, YT, N )
 273       IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
 274          WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
 275          STOP
 276       END IF
 277       TRANS = 'T'
 278       CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
 279      $            YY, EPS, ERR, FATAL, NOUT, .TRUE. )
 280       SAME = LZE( YY, YT, N )
 281       IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
 282          WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
 283          STOP
 284       END IF
 285 *
 286 *     Test each subroutine in turn.
 287 *
 288       DO 210 ISNUM = 1, NSUBS
 289          WRITE( NOUT, FMT = * )
 290          IF( .NOT.LTEST( ISNUM ) )THEN
 291 *           Subprogram is not to be tested.
 292             WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM )
 293          ELSE
 294             SRNAMT = SNAMES( ISNUM )
 295 *           Test error exits.
 296             IF( TSTERR )THEN
 297                CALL ZCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
 298                WRITE( NOUT, FMT = * )
 299             END IF
 300 *           Test computations.
 301             INFOT = 0
 302             OK = .TRUE.
 303             FATAL = .FALSE.
 304             GO TO ( 140, 140, 150, 150, 150, 160, 160,
 305      $              160, 160, 160, 160, 170, 170, 180,
 306      $              180, 190, 190 )ISNUM
 307 *           Test ZGEMV, 01, and ZGBMV, 02.
 308   140       CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 309      $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
 310      $                  NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
 311      $                  X, XX, XS, Y, YY, YS, YT, G )
 312             GO TO 200
 313 *           Test ZHEMV, 03, ZHBMV, 04, and ZHPMV, 05.
 314   150       CALL ZCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 315      $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
 316      $                  NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
 317      $                  X, XX, XS, Y, YY, YS, YT, G )
 318             GO TO 200
 319 *           Test ZTRMV, 06, ZTBMV, 07, ZTPMV, 08,
 320 *           ZTRSV, 09, ZTBSV, 10, and ZTPSV, 11.
 321   160       CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 322      $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
 323      $                  NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z )
 324             GO TO 200
 325 *           Test ZGERC, 12, ZGERU, 13.
 326   170       CALL ZCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 327      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
 328      $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
 329      $                  YT, G, Z )
 330             GO TO 200
 331 *           Test ZHER, 14, and ZHPR, 15.
 332   180       CALL ZCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 333      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
 334      $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
 335      $                  YT, G, Z )
 336             GO TO 200
 337 *           Test ZHER2, 16, and ZHPR2, 17.
 338   190       CALL ZCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 339      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
 340      $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
 341      $                  YT, G, Z )
 342 *
 343   200       IF( FATAL.AND.SFATAL )
 344      $         GO TO 220
 345          END IF
 346   210 CONTINUE
 347       WRITE( NOUT, FMT = 9982 )
 348       GO TO 240
 349 *
 350   220 CONTINUE
 351       WRITE( NOUT, FMT = 9981 )
 352       GO TO 240
 353 *
 354   230 CONTINUE
 355       WRITE( NOUT, FMT = 9987 )
 356 *
 357   240 CONTINUE
 358       IF( TRACE )
 359      $   CLOSE ( NTRA )
 360       CLOSE ( NOUT )
 361       STOP
 362 *
 363  9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
 364      $      'S THAN', F8.2 )
 365  9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
 366  9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
 367      $      'THAN ', I2 )
 368  9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
 369  9995 FORMAT( ' VALUE OF K IS LESS THAN 0' )
 370  9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
 371      $      I2 )
 372  9993 FORMAT( ' TESTS OF THE COMPLEX*16       LEVEL 2 BLAS', //' THE F',
 373      $      'OLLOWING PARAMETER VALUES WILL BE USED:' )
 374  9992 FORMAT( '   FOR N              ', 9I6 )
 375  9991 FORMAT( '   FOR K              ', 7I6 )
 376  9990 FORMAT( '   FOR INCX AND INCY  ', 7I6 )
 377  9989 FORMAT( '   FOR ALPHA          ',
 378      $      7( '(', F4.1, ',', F4.1, ')  ', : ) )
 379  9988 FORMAT( '   FOR BETA           ',
 380      $      7( '(', F4.1, ',', F4.1, ')  ', : ) )
 381  9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
 382      $      /' ******* TESTS ABANDONED *******' )
 383  9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
 384      $      'ESTS ABANDONED *******' )
 385  9985 FORMAT( ' ERROR IN ZMVCH -  IN-LINE DOT PRODUCTS ARE BEING EVALU',
 386      $      'ATED WRONGLY.', /' ZMVCH WAS CALLED WITH TRANS = ', A1,
 387      $      ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', /
 388      $   ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
 389      $      , /' ******* TESTS ABANDONED *******' )
 390  9984 FORMAT( A6, L2 )
 391  9983 FORMAT( 1X, A6, ' WAS NOT TESTED' )
 392  9982 FORMAT( /' END OF TESTS' )
 393  9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
 394  9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
 395 *
 396 *     End of ZBLAT2.
 397 *
 398       END
 399       SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
 400      $                  FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
 401      $                  BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
 402      $                  XS, Y, YY, YS, YT, G )
 403 *
 404 *  Tests ZGEMV and ZGBMV.
 405 *
 406 *  Auxiliary routine for test program for Level 2 Blas.
 407 *
 408 *  -- Written on 10-August-1987.
 409 *     Richard Hanson, Sandia National Labs.
 410 *     Jeremy Du Croz, NAG Central Office.
 411 *
 412 *     .. Parameters ..
 413       COMPLEX*16         ZERO, HALF
 414       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
 415      $                   HALF = ( 0.5D0, 0.0D0 ) )
 416       DOUBLE PRECISION   RZERO
 417       PARAMETER          ( RZERO = 0.0D0 )
 418 *     .. Scalar Arguments ..
 419       DOUBLE PRECISION   EPS, THRESH
 420       INTEGER            INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
 421      $                   NOUT, NTRA
 422       LOGICAL            FATAL, REWI, TRACE
 423       CHARACTER*6        SNAME
 424 *     .. Array Arguments ..
 425       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
 426      $                   AS( NMAX*NMAX ), BET( NBET ), X( NMAX ),
 427      $                   XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
 428      $                   Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
 429      $                   YY( NMAX*INCMAX )
 430       DOUBLE PRECISION   G( NMAX )
 431       INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )
 432 *     .. Local Scalars ..
 433       COMPLEX*16         ALPHA, ALS, BETA, BLS, TRANSL
 434       DOUBLE PRECISION   ERR, ERRMAX
 435       INTEGER            I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
 436      $                   INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
 437      $                   LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
 438      $                   NL, NS
 439       LOGICAL            BANDED, FULL, NULL, RESET, SAME, TRAN
 440       CHARACTER*1        TRANS, TRANSS
 441       CHARACTER*3        ICH
 442 *     .. Local Arrays ..
 443       LOGICAL            ISAME( 13 )
 444 *     .. External Functions ..
 445       LOGICAL            LZE, LZERES
 446       EXTERNAL           LZE, LZERES
 447 *     .. External Subroutines ..
 448       EXTERNAL           ZGBMV, ZGEMV, ZMAKE, ZMVCH
 449 *     .. Intrinsic Functions ..
 450       INTRINSIC          ABS, MAX, MIN
 451 *     .. Scalars in Common ..
 452       INTEGER            INFOT, NOUTC
 453       LOGICAL            LERR, OK
 454 *     .. Common blocks ..
 455       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
 456 *     .. Data statements ..
 457       DATA               ICH/'NTC'/
 458 *     .. Executable Statements ..
 459       FULL = SNAME( 3: 3 ).EQ.'E'
 460       BANDED = SNAME( 3: 3 ).EQ.'B'
 461 *     Define the number of arguments.
 462       IF( FULL )THEN
 463          NARGS = 11
 464       ELSE IF( BANDED )THEN
 465          NARGS = 13
 466       END IF
 467 *
 468       NC = 0
 469       RESET = .TRUE.
 470       ERRMAX = RZERO
 471 *
 472       DO 120 IN = 1, NIDIM
 473          N = IDIM( IN )
 474          ND = N/2 + 1
 475 *
 476          DO 110 IM = 1, 2
 477             IF( IM.EQ.1 )
 478      $         M = MAX( N - ND, 0 )
 479             IF( IM.EQ.2 )
 480      $         M = MIN( N + ND, NMAX )
 481 *
 482             IF( BANDED )THEN
 483                NK = NKB
 484             ELSE
 485                NK = 1
 486             END IF
 487             DO 100 IKU = 1, NK
 488                IF( BANDED )THEN
 489                   KU = KB( IKU )
 490                   KL = MAX( KU - 1, 0 )
 491                ELSE
 492                   KU = N - 1
 493                   KL = M - 1
 494                END IF
 495 *              Set LDA to 1 more than minimum value if room.
 496                IF( BANDED )THEN
 497                   LDA = KL + KU + 1
 498                ELSE
 499                   LDA = M
 500                END IF
 501                IF( LDA.LT.NMAX )
 502      $            LDA = LDA + 1
 503 *              Skip tests if not enough room.
 504                IF( LDA.GT.NMAX )
 505      $            GO TO 100
 506                LAA = LDA*N
 507                NULL = N.LE.0.OR.M.LE.0
 508 *
 509 *              Generate the matrix A.
 510 *
 511                TRANSL = ZERO
 512                CALL ZMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA,
 513      $                     LDA, KL, KU, RESET, TRANSL )
 514 *
 515                DO 90 IC = 1, 3
 516                   TRANS = ICH( IC: IC )
 517                   TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
 518 *
 519                   IF( TRAN )THEN
 520                      ML = N
 521                      NL = M
 522                   ELSE
 523                      ML = M
 524                      NL = N
 525                   END IF
 526 *
 527                   DO 80 IX = 1, NINC
 528                      INCX = INC( IX )
 529                      LX = ABS( INCX )*NL
 530 *
 531 *                    Generate the vector X.
 532 *
 533                      TRANSL = HALF
 534                      CALL ZMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX,
 535      $                           ABS( INCX ), 0, NL - 1, RESET, TRANSL )
 536                      IF( NL.GT.1 )THEN
 537                         X( NL/2 ) = ZERO
 538                         XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO
 539                      END IF
 540 *
 541                      DO 70 IY = 1, NINC
 542                         INCY = INC( IY )
 543                         LY = ABS( INCY )*ML
 544 *
 545                         DO 60 IA = 1, NALF
 546                            ALPHA = ALF( IA )
 547 *
 548                            DO 50 IB = 1, NBET
 549                               BETA = BET( IB )
 550 *
 551 *                             Generate the vector Y.
 552 *
 553                               TRANSL = ZERO
 554                               CALL ZMAKE( 'GE', ' ', ' ', 1, ML, Y, 1,
 555      $                                    YY, ABS( INCY ), 0, ML - 1,
 556      $                                    RESET, TRANSL )
 557 *
 558                               NC = NC + 1
 559 *
 560 *                             Save every datum before calling the
 561 *                             subroutine.
 562 *
 563                               TRANSS = TRANS
 564                               MS = M
 565                               NS = N
 566                               KLS = KL
 567                               KUS = KU
 568                               ALS = ALPHA
 569                               DO 10 I = 1, LAA
 570                                  AS( I ) = AA( I )
 571    10                         CONTINUE
 572                               LDAS = LDA
 573                               DO 20 I = 1, LX
 574                                  XS( I ) = XX( I )
 575    20                         CONTINUE
 576                               INCXS = INCX
 577                               BLS = BETA
 578                               DO 30 I = 1, LY
 579                                  YS( I ) = YY( I )
 580    30                         CONTINUE
 581                               INCYS = INCY
 582 *
 583 *                             Call the subroutine.
 584 *
 585                               IF( FULL )THEN
 586                                  IF( TRACE )
 587      $                              WRITE( NTRA, FMT = 9994 )NC, SNAME,
 588      $                              TRANS, M, N, ALPHA, LDA, INCX, BETA,
 589      $                              INCY
 590                                  IF( REWI )
 591      $                              REWIND NTRA
 592                                  CALL ZGEMV( TRANS, M, N, ALPHA, AA,
 593      $                                       LDA, XX, INCX, BETA, YY,
 594      $                                       INCY )
 595                               ELSE IF( BANDED )THEN
 596                                  IF( TRACE )
 597      $                              WRITE( NTRA, FMT = 9995 )NC, SNAME,
 598      $                              TRANS, M, N, KL, KU, ALPHA, LDA,
 599      $                              INCX, BETA, INCY
 600                                  IF( REWI )
 601      $                              REWIND NTRA
 602                                  CALL ZGBMV( TRANS, M, N, KL, KU, ALPHA,
 603      $                                       AA, LDA, XX, INCX, BETA,
 604      $                                       YY, INCY )
 605                               END IF
 606 *
 607 *                             Check if error-exit was taken incorrectly.
 608 *
 609                               IF( .NOT.OK )THEN
 610                                  WRITE( NOUT, FMT = 9993 )
 611                                  FATAL = .TRUE.
 612                                  GO TO 130
 613                               END IF
 614 *
 615 *                             See what data changed inside subroutines.
 616 *
 617                               ISAME( 1 ) = TRANS.EQ.TRANSS
 618                               ISAME( 2 ) = MS.EQ.M
 619                               ISAME( 3 ) = NS.EQ.N
 620                               IF( FULL )THEN
 621                                  ISAME( 4 ) = ALS.EQ.ALPHA
 622                                  ISAME( 5 ) = LZE( AS, AA, LAA )
 623                                  ISAME( 6 ) = LDAS.EQ.LDA
 624                                  ISAME( 7 ) = LZE( XS, XX, LX )
 625                                  ISAME( 8 ) = INCXS.EQ.INCX
 626                                  ISAME( 9 ) = BLS.EQ.BETA
 627                                  IF( NULL )THEN
 628                                     ISAME( 10 ) = LZE( YS, YY, LY )
 629                                  ELSE
 630                                     ISAME( 10 ) = LZERES( 'GE', ' ', 1,
 631      $                                            ML, YS, YY,
 632      $                                            ABS( INCY ) )
 633                                  END IF
 634                                  ISAME( 11 ) = INCYS.EQ.INCY
 635                               ELSE IF( BANDED )THEN
 636                                  ISAME( 4 ) = KLS.EQ.KL
 637                                  ISAME( 5 ) = KUS.EQ.KU
 638                                  ISAME( 6 ) = ALS.EQ.ALPHA
 639                                  ISAME( 7 ) = LZE( AS, AA, LAA )
 640                                  ISAME( 8 ) = LDAS.EQ.LDA
 641                                  ISAME( 9 ) = LZE( XS, XX, LX )
 642                                  ISAME( 10 ) = INCXS.EQ.INCX
 643                                  ISAME( 11 ) = BLS.EQ.BETA
 644                                  IF( NULL )THEN
 645                                     ISAME( 12 ) = LZE( YS, YY, LY )
 646                                  ELSE
 647                                     ISAME( 12 ) = LZERES( 'GE', ' ', 1,
 648      $                                            ML, YS, YY,
 649      $                                            ABS( INCY ) )
 650                                  END IF
 651                                  ISAME( 13 ) = INCYS.EQ.INCY
 652                               END IF
 653 *
 654 *                             If data was incorrectly changed, report
 655 *                             and return.
 656 *
 657                               SAME = .TRUE.
 658                               DO 40 I = 1, NARGS
 659                                  SAME = SAME.AND.ISAME( I )
 660                                  IF( .NOT.ISAME( I ) )
 661      $                              WRITE( NOUT, FMT = 9998 )I
 662    40                         CONTINUE
 663                               IF( .NOT.SAME )THEN
 664                                  FATAL = .TRUE.
 665                                  GO TO 130
 666                               END IF
 667 *
 668                               IF( .NOT.NULL )THEN
 669 *
 670 *                                Check the result.
 671 *
 672                                  CALL ZMVCH( TRANS, M, N, ALPHA, A,
 673      $                                       NMAX, X, INCX, BETA, Y,
 674      $                                       INCY, YT, G, YY, EPS, ERR,
 675      $                                       FATAL, NOUT, .TRUE. )
 676                                  ERRMAX = MAX( ERRMAX, ERR )
 677 *                                If got really bad answer, report and
 678 *                                return.
 679                                  IF( FATAL )
 680      $                              GO TO 130
 681                               ELSE
 682 *                                Avoid repeating tests with M.le.0 or
 683 *                                N.le.0.
 684                                  GO TO 110
 685                               END IF
 686 *
 687    50                      CONTINUE
 688 *
 689    60                   CONTINUE
 690 *
 691    70                CONTINUE
 692 *
 693    80             CONTINUE
 694 *
 695    90          CONTINUE
 696 *
 697   100       CONTINUE
 698 *
 699   110    CONTINUE
 700 *
 701   120 CONTINUE
 702 *
 703 *     Report result.
 704 *
 705       IF( ERRMAX.LT.THRESH )THEN
 706          WRITE( NOUT, FMT = 9999 )SNAME, NC
 707       ELSE
 708          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
 709       END IF
 710       GO TO 140
 711 *
 712   130 CONTINUE
 713       WRITE( NOUT, FMT = 9996 )SNAME
 714       IF( FULL )THEN
 715          WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA,
 716      $      INCX, BETA, INCY
 717       ELSE IF( BANDED )THEN
 718          WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU,
 719      $      ALPHA, LDA, INCX, BETA, INCY
 720       END IF
 721 *
 722   140 CONTINUE
 723       RETURN
 724 *
 725  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
 726      $      'S)' )
 727  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
 728      $      'ANGED INCORRECTLY *******' )
 729  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
 730      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
 731      $      ' - SUSPECT *******' )
 732  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
 733  9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), '(',
 734      $      F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',
 735      $      F4.1, '), Y,', I2, ') .' )
 736  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(',
 737      $      F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',
 738      $      F4.1, '), Y,', I2, ')         .' )
 739  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
 740      $      '******' )
 741 *
 742 *     End of ZCHK1.
 743 *
 744       END
 745       SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
 746      $                  FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
 747      $                  BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
 748      $                  XS, Y, YY, YS, YT, G )
 749 *
 750 *  Tests ZHEMV, ZHBMV and ZHPMV.
 751 *
 752 *  Auxiliary routine for test program for Level 2 Blas.
 753 *
 754 *  -- Written on 10-August-1987.
 755 *     Richard Hanson, Sandia National Labs.
 756 *     Jeremy Du Croz, NAG Central Office.
 757 *
 758 *     .. Parameters ..
 759       COMPLEX*16         ZERO, HALF
 760       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
 761      $                   HALF = ( 0.5D0, 0.0D0 ) )
 762       DOUBLE PRECISION   RZERO
 763       PARAMETER          ( RZERO = 0.0D0 )
 764 *     .. Scalar Arguments ..
 765       DOUBLE PRECISION   EPS, THRESH
 766       INTEGER            INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
 767      $                   NOUT, NTRA
 768       LOGICAL            FATAL, REWI, TRACE
 769       CHARACTER*6        SNAME
 770 *     .. Array Arguments ..
 771       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
 772      $                   AS( NMAX*NMAX ), BET( NBET ), X( NMAX ),
 773      $                   XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
 774      $                   Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
 775      $                   YY( NMAX*INCMAX )
 776       DOUBLE PRECISION   G( NMAX )
 777       INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )
 778 *     .. Local Scalars ..
 779       COMPLEX*16         ALPHA, ALS, BETA, BLS, TRANSL
 780       DOUBLE PRECISION   ERR, ERRMAX
 781       INTEGER            I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
 782      $                   INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
 783      $                   N, NARGS, NC, NK, NS
 784       LOGICAL            BANDED, FULL, NULL, PACKED, RESET, SAME
 785       CHARACTER*1        UPLO, UPLOS
 786       CHARACTER*2        ICH
 787 *     .. Local Arrays ..
 788       LOGICAL            ISAME( 13 )
 789 *     .. External Functions ..
 790       LOGICAL            LZE, LZERES
 791       EXTERNAL           LZE, LZERES
 792 *     .. External Subroutines ..
 793       EXTERNAL           ZHBMV, ZHEMV, ZHPMV, ZMAKE, ZMVCH
 794 *     .. Intrinsic Functions ..
 795       INTRINSIC          ABS, MAX
 796 *     .. Scalars in Common ..
 797       INTEGER            INFOT, NOUTC
 798       LOGICAL            LERR, OK
 799 *     .. Common blocks ..
 800       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
 801 *     .. Data statements ..
 802       DATA               ICH/'UL'/
 803 *     .. Executable Statements ..
 804       FULL = SNAME( 3: 3 ).EQ.'E'
 805       BANDED = SNAME( 3: 3 ).EQ.'B'
 806       PACKED = SNAME( 3: 3 ).EQ.'P'
 807 *     Define the number of arguments.
 808       IF( FULL )THEN
 809          NARGS = 10
 810       ELSE IF( BANDED )THEN
 811          NARGS = 11
 812       ELSE IF( PACKED )THEN
 813          NARGS = 9
 814       END IF
 815 *
 816       NC = 0
 817       RESET = .TRUE.
 818       ERRMAX = RZERO
 819 *
 820       DO 110 IN = 1, NIDIM
 821          N = IDIM( IN )
 822 *
 823          IF( BANDED )THEN
 824             NK = NKB
 825          ELSE
 826             NK = 1
 827          END IF
 828          DO 100 IK = 1, NK
 829             IF( BANDED )THEN
 830                K = KB( IK )
 831             ELSE
 832                K = N - 1
 833             END IF
 834 *           Set LDA to 1 more than minimum value if room.
 835             IF( BANDED )THEN
 836                LDA = K + 1
 837             ELSE
 838                LDA = N
 839             END IF
 840             IF( LDA.LT.NMAX )
 841      $         LDA = LDA + 1
 842 *           Skip tests if not enough room.
 843             IF( LDA.GT.NMAX )
 844      $         GO TO 100
 845             IF( PACKED )THEN
 846                LAA = ( N*( N + 1 ) )/2
 847             ELSE
 848                LAA = LDA*N
 849             END IF
 850             NULL = N.LE.0
 851 *
 852             DO 90 IC = 1, 2
 853                UPLO = ICH( IC: IC )
 854 *
 855 *              Generate the matrix A.
 856 *
 857                TRANSL = ZERO
 858                CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA,
 859      $                     LDA, K, K, RESET, TRANSL )
 860 *
 861                DO 80 IX = 1, NINC
 862                   INCX = INC( IX )
 863                   LX = ABS( INCX )*N
 864 *
 865 *                 Generate the vector X.
 866 *
 867                   TRANSL = HALF
 868                   CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
 869      $                        ABS( INCX ), 0, N - 1, RESET, TRANSL )
 870                   IF( N.GT.1 )THEN
 871                      X( N/2 ) = ZERO
 872                      XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
 873                   END IF
 874 *
 875                   DO 70 IY = 1, NINC
 876                      INCY = INC( IY )
 877                      LY = ABS( INCY )*N
 878 *
 879                      DO 60 IA = 1, NALF
 880                         ALPHA = ALF( IA )
 881 *
 882                         DO 50 IB = 1, NBET
 883                            BETA = BET( IB )
 884 *
 885 *                          Generate the vector Y.
 886 *
 887                            TRANSL = ZERO
 888                            CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
 889      $                                 ABS( INCY ), 0, N - 1, RESET,
 890      $                                 TRANSL )
 891 *
 892                            NC = NC + 1
 893 *
 894 *                          Save every datum before calling the
 895 *                          subroutine.
 896 *
 897                            UPLOS = UPLO
 898                            NS = N
 899                            KS = K
 900                            ALS = ALPHA
 901                            DO 10 I = 1, LAA
 902                               AS( I ) = AA( I )
 903    10                      CONTINUE
 904                            LDAS = LDA
 905                            DO 20 I = 1, LX
 906                               XS( I ) = XX( I )
 907    20                      CONTINUE
 908                            INCXS = INCX
 909                            BLS = BETA
 910                            DO 30 I = 1, LY
 911                               YS( I ) = YY( I )
 912    30                      CONTINUE
 913                            INCYS = INCY
 914 *
 915 *                          Call the subroutine.
 916 *
 917                            IF( FULL )THEN
 918                               IF( TRACE )
 919      $                           WRITE( NTRA, FMT = 9993 )NC, SNAME,
 920      $                           UPLO, N, ALPHA, LDA, INCX, BETA, INCY
 921                               IF( REWI )
 922      $                           REWIND NTRA
 923                               CALL ZHEMV( UPLO, N, ALPHA, AA, LDA, XX,
 924      $                                    INCX, BETA, YY, INCY )
 925                            ELSE IF( BANDED )THEN
 926                               IF( TRACE )
 927      $                           WRITE( NTRA, FMT = 9994 )NC, SNAME,
 928      $                           UPLO, N, K, ALPHA, LDA, INCX, BETA,
 929      $                           INCY
 930                               IF( REWI )
 931      $                           REWIND NTRA
 932                               CALL ZHBMV( UPLO, N, K, ALPHA, AA, LDA,
 933      $                                    XX, INCX, BETA, YY, INCY )
 934                            ELSE IF( PACKED )THEN
 935                               IF( TRACE )
 936      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
 937      $                           UPLO, N, ALPHA, INCX, BETA, INCY
 938                               IF( REWI )
 939      $                           REWIND NTRA
 940                               CALL ZHPMV( UPLO, N, ALPHA, AA, XX, INCX,
 941      $                                    BETA, YY, INCY )
 942                            END IF
 943 *
 944 *                          Check if error-exit was taken incorrectly.
 945 *
 946                            IF( .NOT.OK )THEN
 947                               WRITE( NOUT, FMT = 9992 )
 948                               FATAL = .TRUE.
 949                               GO TO 120
 950                            END IF
 951 *
 952 *                          See what data changed inside subroutines.
 953 *
 954                            ISAME( 1 ) = UPLO.EQ.UPLOS
 955                            ISAME( 2 ) = NS.EQ.N
 956                            IF( FULL )THEN
 957                               ISAME( 3 ) = ALS.EQ.ALPHA
 958                               ISAME( 4 ) = LZE( AS, AA, LAA )
 959                               ISAME( 5 ) = LDAS.EQ.LDA
 960                               ISAME( 6 ) = LZE( XS, XX, LX )
 961                               ISAME( 7 ) = INCXS.EQ.INCX
 962                               ISAME( 8 ) = BLS.EQ.BETA
 963                               IF( NULL )THEN
 964                                  ISAME( 9 ) = LZE( YS, YY, LY )
 965                               ELSE
 966                                  ISAME( 9 ) = LZERES( 'GE', ' ', 1, N,
 967      $                                        YS, YY, ABS( INCY ) )
 968                               END IF
 969                               ISAME( 10 ) = INCYS.EQ.INCY
 970                            ELSE IF( BANDED )THEN
 971                               ISAME( 3 ) = KS.EQ.K
 972                               ISAME( 4 ) = ALS.EQ.ALPHA
 973                               ISAME( 5 ) = LZE( AS, AA, LAA )
 974                               ISAME( 6 ) = LDAS.EQ.LDA
 975                               ISAME( 7 ) = LZE( XS, XX, LX )
 976                               ISAME( 8 ) = INCXS.EQ.INCX
 977                               ISAME( 9 ) = BLS.EQ.BETA
 978                               IF( NULL )THEN
 979                                  ISAME( 10 ) = LZE( YS, YY, LY )
 980                               ELSE
 981                                  ISAME( 10 ) = LZERES( 'GE', ' ', 1, N,
 982      $                                         YS, YY, ABS( INCY ) )
 983                               END IF
 984                               ISAME( 11 ) = INCYS.EQ.INCY
 985                            ELSE IF( PACKED )THEN
 986                               ISAME( 3 ) = ALS.EQ.ALPHA
 987                               ISAME( 4 ) = LZE( AS, AA, LAA )
 988                               ISAME( 5 ) = LZE( XS, XX, LX )
 989                               ISAME( 6 ) = INCXS.EQ.INCX
 990                               ISAME( 7 ) = BLS.EQ.BETA
 991                               IF( NULL )THEN
 992                                  ISAME( 8 ) = LZE( YS, YY, LY )
 993                               ELSE
 994                                  ISAME( 8 ) = LZERES( 'GE', ' ', 1, N,
 995      $                                        YS, YY, ABS( INCY ) )
 996                               END IF
 997                               ISAME( 9 ) = INCYS.EQ.INCY
 998                            END IF
 999 *
1000 *                          If data was incorrectly changed, report and
1001 *                          return.
1002 *
1003                            SAME = .TRUE.
1004                            DO 40 I = 1, NARGS
1005                               SAME = SAME.AND.ISAME( I )
1006                               IF( .NOT.ISAME( I ) )
1007      $                           WRITE( NOUT, FMT = 9998 )I
1008    40                      CONTINUE
1009                            IF( .NOT.SAME )THEN
1010                               FATAL = .TRUE.
1011                               GO TO 120
1012                            END IF
1013 *
1014                            IF( .NOT.NULL )THEN
1015 *
1016 *                             Check the result.
1017 *
1018                               CALL ZMVCH( 'N', N, N, ALPHA, A, NMAX, X,
1019      $                                    INCX, BETA, Y, INCY, YT, G,
1020      $                                    YY, EPS, ERR, FATAL, NOUT,
1021      $                                    .TRUE. )
1022                               ERRMAX = MAX( ERRMAX, ERR )
1023 *                             If got really bad answer, report and
1024 *                             return.
1025                               IF( FATAL )
1026      $                           GO TO 120
1027                            ELSE
1028 *                             Avoid repeating tests with N.le.0
1029                               GO TO 110
1030                            END IF
1031 *
1032    50                   CONTINUE
1033 *
1034    60                CONTINUE
1035 *
1036    70             CONTINUE
1037 *
1038    80          CONTINUE
1039 *
1040    90       CONTINUE
1041 *
1042   100    CONTINUE
1043 *
1044   110 CONTINUE
1045 *
1046 *     Report result.
1047 *
1048       IF( ERRMAX.LT.THRESH )THEN
1049          WRITE( NOUT, FMT = 9999 )SNAME, NC
1050       ELSE
1051          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1052       END IF
1053       GO TO 130
1054 *
1055   120 CONTINUE
1056       WRITE( NOUT, FMT = 9996 )SNAME
1057       IF( FULL )THEN
1058          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX,
1059      $      BETA, INCY
1060       ELSE IF( BANDED )THEN
1061          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA,
1062      $      INCX, BETA, INCY
1063       ELSE IF( PACKED )THEN
1064          WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX,
1065      $      BETA, INCY
1066       END IF
1067 *
1068   130 CONTINUE
1069       RETURN
1070 *
1071  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1072      $      'S)' )
1073  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1074      $      'ANGED INCORRECTLY *******' )
1075  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1076      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1077      $      ' - SUSPECT *******' )
1078  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1079  9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
1080      $      F4.1, '), AP, X,', I2, ',(', F4.1, ',', F4.1, '), Y,', I2,
1081      $      ')                .' )
1082  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(',
1083      $      F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',
1084      $      F4.1, '), Y,', I2, ')         .' )
1085  9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
1086      $      F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', F4.1, '), ',
1087      $      'Y,', I2, ')             .' )
1088  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1089      $      '******' )
1090 *
1091 *     End of ZCHK2.
1092 *
1093       END
1094       SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1095      $                  FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
1096      $                  INCMAX, A, AA, AS, X, XX, XS, XT, G, Z )
1097 *
1098 *  Tests ZTRMV, ZTBMV, ZTPMV, ZTRSV, ZTBSV and ZTPSV.
1099 *
1100 *  Auxiliary routine for test program for Level 2 Blas.
1101 *
1102 *  -- Written on 10-August-1987.
1103 *     Richard Hanson, Sandia National Labs.
1104 *     Jeremy Du Croz, NAG Central Office.
1105 *
1106 *     .. Parameters ..
1107       COMPLEX*16         ZERO, HALF, ONE
1108       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
1109      $                   HALF = ( 0.5D0, 0.0D0 ),
1110      $                   ONE = ( 1.0D0, 0.0D0 ) )
1111       DOUBLE PRECISION   RZERO
1112       PARAMETER          ( RZERO = 0.0D0 )
1113 *     .. Scalar Arguments ..
1114       DOUBLE PRECISION   EPS, THRESH
1115       INTEGER            INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
1116       LOGICAL            FATAL, REWI, TRACE
1117       CHARACTER*6        SNAME
1118 *     .. Array Arguments ..
1119       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ),
1120      $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
1121      $                   XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX )
1122       DOUBLE PRECISION   G( NMAX )
1123       INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )
1124 *     .. Local Scalars ..
1125       COMPLEX*16         TRANSL
1126       DOUBLE PRECISION   ERR, ERRMAX
1127       INTEGER            I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
1128      $                   KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
1129       LOGICAL            BANDED, FULL, NULL, PACKED, RESET, SAME
1130       CHARACTER*1        DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
1131       CHARACTER*2        ICHD, ICHU
1132       CHARACTER*3        ICHT
1133 *     .. Local Arrays ..
1134       LOGICAL            ISAME( 13 )
1135 *     .. External Functions ..
1136       LOGICAL            LZE, LZERES
1137       EXTERNAL           LZE, LZERES
1138 *     .. External Subroutines ..
1139       EXTERNAL           ZMAKE, ZMVCH, ZTBMV, ZTBSV, ZTPMV, ZTPSV,
1140      $                   ZTRMV, ZTRSV
1141 *     .. Intrinsic Functions ..
1142       INTRINSIC          ABS, MAX
1143 *     .. Scalars in Common ..
1144       INTEGER            INFOT, NOUTC
1145       LOGICAL            LERR, OK
1146 *     .. Common blocks ..
1147       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
1148 *     .. Data statements ..
1149       DATA               ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/
1150 *     .. Executable Statements ..
1151       FULL = SNAME( 3: 3 ).EQ.'R'
1152       BANDED = SNAME( 3: 3 ).EQ.'B'
1153       PACKED = SNAME( 3: 3 ).EQ.'P'
1154 *     Define the number of arguments.
1155       IF( FULL )THEN
1156          NARGS = 8
1157       ELSE IF( BANDED )THEN
1158          NARGS = 9
1159       ELSE IF( PACKED )THEN
1160          NARGS = 7
1161       END IF
1162 *
1163       NC = 0
1164       RESET = .TRUE.
1165       ERRMAX = RZERO
1166 *     Set up zero vector for ZMVCH.
1167       DO 10 I = 1, NMAX
1168          Z( I ) = ZERO
1169    10 CONTINUE
1170 *
1171       DO 110 IN = 1, NIDIM
1172          N = IDIM( IN )
1173 *
1174          IF( BANDED )THEN
1175             NK = NKB
1176          ELSE
1177             NK = 1
1178          END IF
1179          DO 100 IK = 1, NK
1180             IF( BANDED )THEN
1181                K = KB( IK )
1182             ELSE
1183                K = N - 1
1184             END IF
1185 *           Set LDA to 1 more than minimum value if room.
1186             IF( BANDED )THEN
1187                LDA = K + 1
1188             ELSE
1189                LDA = N
1190             END IF
1191             IF( LDA.LT.NMAX )
1192      $         LDA = LDA + 1
1193 *           Skip tests if not enough room.
1194             IF( LDA.GT.NMAX )
1195      $         GO TO 100
1196             IF( PACKED )THEN
1197                LAA = ( N*( N + 1 ) )/2
1198             ELSE
1199                LAA = LDA*N
1200             END IF
1201             NULL = N.LE.0
1202 *
1203             DO 90 ICU = 1, 2
1204                UPLO = ICHU( ICU: ICU )
1205 *
1206                DO 80 ICT = 1, 3
1207                   TRANS = ICHT( ICT: ICT )
1208 *
1209                   DO 70 ICD = 1, 2
1210                      DIAG = ICHD( ICD: ICD )
1211 *
1212 *                    Generate the matrix A.
1213 *
1214                      TRANSL = ZERO
1215                      CALL ZMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A,
1216      $                           NMAX, AA, LDA, K, K, RESET, TRANSL )
1217 *
1218                      DO 60 IX = 1, NINC
1219                         INCX = INC( IX )
1220                         LX = ABS( INCX )*N
1221 *
1222 *                       Generate the vector X.
1223 *
1224                         TRANSL = HALF
1225                         CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
1226      $                              ABS( INCX ), 0, N - 1, RESET,
1227      $                              TRANSL )
1228                         IF( N.GT.1 )THEN
1229                            X( N/2 ) = ZERO
1230                            XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1231                         END IF
1232 *
1233                         NC = NC + 1
1234 *
1235 *                       Save every datum before calling the subroutine.
1236 *
1237                         UPLOS = UPLO
1238                         TRANSS = TRANS
1239                         DIAGS = DIAG
1240                         NS = N
1241                         KS = K
1242                         DO 20 I = 1, LAA
1243                            AS( I ) = AA( I )
1244    20                   CONTINUE
1245                         LDAS = LDA
1246                         DO 30 I = 1, LX
1247                            XS( I ) = XX( I )
1248    30                   CONTINUE
1249                         INCXS = INCX
1250 *
1251 *                       Call the subroutine.
1252 *
1253                         IF( SNAME( 4: 5 ).EQ.'MV' )THEN
1254                            IF( FULL )THEN
1255                               IF( TRACE )
1256      $                           WRITE( NTRA, FMT = 9993 )NC, SNAME,
1257      $                           UPLO, TRANS, DIAG, N, LDA, INCX
1258                               IF( REWI )
1259      $                           REWIND NTRA
1260                               CALL ZTRMV( UPLO, TRANS, DIAG, N, AA, LDA,
1261      $                                    XX, INCX )
1262                            ELSE IF( BANDED )THEN
1263                               IF( TRACE )
1264      $                           WRITE( NTRA, FMT = 9994 )NC, SNAME,
1265      $                           UPLO, TRANS, DIAG, N, K, LDA, INCX
1266                               IF( REWI )
1267      $                           REWIND NTRA
1268                               CALL ZTBMV( UPLO, TRANS, DIAG, N, K, AA,
1269      $                                    LDA, XX, INCX )
1270                            ELSE IF( PACKED )THEN
1271                               IF( TRACE )
1272      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
1273      $                           UPLO, TRANS, DIAG, N, INCX
1274                               IF( REWI )
1275      $                           REWIND NTRA
1276                               CALL ZTPMV( UPLO, TRANS, DIAG, N, AA, XX,
1277      $                                    INCX )
1278                            END IF
1279                         ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
1280                            IF( FULL )THEN
1281                               IF( TRACE )
1282      $                           WRITE( NTRA, FMT = 9993 )NC, SNAME,
1283      $                           UPLO, TRANS, DIAG, N, LDA, INCX
1284                               IF( REWI )
1285      $                           REWIND NTRA
1286                               CALL ZTRSV( UPLO, TRANS, DIAG, N, AA, LDA,
1287      $                                    XX, INCX )
1288                            ELSE IF( BANDED )THEN
1289                               IF( TRACE )
1290      $                           WRITE( NTRA, FMT = 9994 )NC, SNAME,
1291      $                           UPLO, TRANS, DIAG, N, K, LDA, INCX
1292                               IF( REWI )
1293      $                           REWIND NTRA
1294                               CALL ZTBSV( UPLO, TRANS, DIAG, N, K, AA,
1295      $                                    LDA, XX, INCX )
1296                            ELSE IF( PACKED )THEN
1297                               IF( TRACE )
1298      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
1299      $                           UPLO, TRANS, DIAG, N, INCX
1300                               IF( REWI )
1301      $                           REWIND NTRA
1302                               CALL ZTPSV( UPLO, TRANS, DIAG, N, AA, XX,
1303      $                                    INCX )
1304                            END IF
1305                         END IF
1306 *
1307 *                       Check if error-exit was taken incorrectly.
1308 *
1309                         IF( .NOT.OK )THEN
1310                            WRITE( NOUT, FMT = 9992 )
1311                            FATAL = .TRUE.
1312                            GO TO 120
1313                         END IF
1314 *
1315 *                       See what data changed inside subroutines.
1316 *
1317                         ISAME( 1 ) = UPLO.EQ.UPLOS
1318                         ISAME( 2 ) = TRANS.EQ.TRANSS
1319                         ISAME( 3 ) = DIAG.EQ.DIAGS
1320                         ISAME( 4 ) = NS.EQ.N
1321                         IF( FULL )THEN
1322                            ISAME( 5 ) = LZE( AS, AA, LAA )
1323                            ISAME( 6 ) = LDAS.EQ.LDA
1324                            IF( NULL )THEN
1325                               ISAME( 7 ) = LZE( XS, XX, LX )
1326                            ELSE
1327                               ISAME( 7 ) = LZERES( 'GE', ' ', 1, N, XS,
1328      $                                     XX, ABS( INCX ) )
1329                            END IF
1330                            ISAME( 8 ) = INCXS.EQ.INCX
1331                         ELSE IF( BANDED )THEN
1332                            ISAME( 5 ) = KS.EQ.K
1333                            ISAME( 6 ) = LZE( AS, AA, LAA )
1334                            ISAME( 7 ) = LDAS.EQ.LDA
1335                            IF( NULL )THEN
1336                               ISAME( 8 ) = LZE( XS, XX, LX )
1337                            ELSE
1338                               ISAME( 8 ) = LZERES( 'GE', ' ', 1, N, XS,
1339      $                                     XX, ABS( INCX ) )
1340                            END IF
1341                            ISAME( 9 ) = INCXS.EQ.INCX
1342                         ELSE IF( PACKED )THEN
1343                            ISAME( 5 ) = LZE( AS, AA, LAA )
1344                            IF( NULL )THEN
1345                               ISAME( 6 ) = LZE( XS, XX, LX )
1346                            ELSE
1347                               ISAME( 6 ) = LZERES( 'GE', ' ', 1, N, XS,
1348      $                                     XX, ABS( INCX ) )
1349                            END IF
1350                            ISAME( 7 ) = INCXS.EQ.INCX
1351                         END IF
1352 *
1353 *                       If data was incorrectly changed, report and
1354 *                       return.
1355 *
1356                         SAME = .TRUE.
1357                         DO 40 I = 1, NARGS
1358                            SAME = SAME.AND.ISAME( I )
1359                            IF( .NOT.ISAME( I ) )
1360      $                        WRITE( NOUT, FMT = 9998 )I
1361    40                   CONTINUE
1362                         IF( .NOT.SAME )THEN
1363                            FATAL = .TRUE.
1364                            GO TO 120
1365                         END IF
1366 *
1367                         IF( .NOT.NULL )THEN
1368                            IF( SNAME( 4: 5 ).EQ.'MV' )THEN
1369 *
1370 *                             Check the result.
1371 *
1372                               CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X,
1373      $                                    INCX, ZERO, Z, INCX, XT, G,
1374      $                                    XX, EPS, ERR, FATAL, NOUT,
1375      $                                    .TRUE. )
1376                            ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
1377 *
1378 *                             Compute approximation to original vector.
1379 *
1380                               DO 50 I = 1, N
1381                                  Z( I ) = XX( 1 + ( I - 1 )*
1382      $                                    ABS( INCX ) )
1383                                  XX( 1 + ( I - 1 )*ABS( INCX ) )
1384      $                              = X( I )
1385    50                         CONTINUE
1386                               CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, Z,
1387      $                                    INCX, ZERO, X, INCX, XT, G,
1388      $                                    XX, EPS, ERR, FATAL, NOUT,
1389      $                                    .FALSE. )
1390                            END IF
1391                            ERRMAX = MAX( ERRMAX, ERR )
1392 *                          If got really bad answer, report and return.
1393                            IF( FATAL )
1394      $                        GO TO 120
1395                         ELSE
1396 *                          Avoid repeating tests with N.le.0.
1397                            GO TO 110
1398                         END IF
1399 *
1400    60                CONTINUE
1401 *
1402    70             CONTINUE
1403 *
1404    80          CONTINUE
1405 *
1406    90       CONTINUE
1407 *
1408   100    CONTINUE
1409 *
1410   110 CONTINUE
1411 *
1412 *     Report result.
1413 *
1414       IF( ERRMAX.LT.THRESH )THEN
1415          WRITE( NOUT, FMT = 9999 )SNAME, NC
1416       ELSE
1417          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1418       END IF
1419       GO TO 130
1420 *
1421   120 CONTINUE
1422       WRITE( NOUT, FMT = 9996 )SNAME
1423       IF( FULL )THEN
1424          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA,
1425      $      INCX
1426       ELSE IF( BANDED )THEN
1427          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K,
1428      $      LDA, INCX
1429       ELSE IF( PACKED )THEN
1430          WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX
1431       END IF
1432 *
1433   130 CONTINUE
1434       RETURN
1435 *
1436  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1437      $      'S)' )
1438  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1439      $      'ANGED INCORRECTLY *******' )
1440  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1441      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1442      $      ' - SUSPECT *******' )
1443  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1444  9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ',
1445      $      'X,', I2, ')                                      .' )
1446  9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ),
1447      $      ' A,', I3, ', X,', I2, ')                               .' )
1448  9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,',
1449      $      I3, ', X,', I2, ')                                   .' )
1450  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1451      $      '******' )
1452 *
1453 *     End of ZCHK3.
1454 *
1455       END
1456       SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1457      $                  FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1458      $                  INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1459      $                  Z )
1460 *
1461 *  Tests ZGERC and ZGERU.
1462 *
1463 *  Auxiliary routine for test program for Level 2 Blas.
1464 *
1465 *  -- Written on 10-August-1987.
1466 *     Richard Hanson, Sandia National Labs.
1467 *     Jeremy Du Croz, NAG Central Office.
1468 *
1469 *     .. Parameters ..
1470       COMPLEX*16         ZERO, HALF, ONE
1471       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
1472      $                   HALF = ( 0.5D0, 0.0D0 ),
1473      $                   ONE = ( 1.0D0, 0.0D0 ) )
1474       DOUBLE PRECISION   RZERO
1475       PARAMETER          ( RZERO = 0.0D0 )
1476 *     .. Scalar Arguments ..
1477       DOUBLE PRECISION   EPS, THRESH
1478       INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1479       LOGICAL            FATAL, REWI, TRACE
1480       CHARACTER*6        SNAME
1481 *     .. Array Arguments ..
1482       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1483      $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
1484      $                   XX( NMAX*INCMAX ), Y( NMAX ),
1485      $                   YS( NMAX*INCMAX ), YT( NMAX ),
1486      $                   YY( NMAX*INCMAX ), Z( NMAX )
1487       DOUBLE PRECISION   G( NMAX )
1488       INTEGER            IDIM( NIDIM ), INC( NINC )
1489 *     .. Local Scalars ..
1490       COMPLEX*16         ALPHA, ALS, TRANSL
1491       DOUBLE PRECISION   ERR, ERRMAX
1492       INTEGER            I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
1493      $                   IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
1494      $                   NC, ND, NS
1495       LOGICAL            CONJ, NULL, RESET, SAME
1496 *     .. Local Arrays ..
1497       COMPLEX*16         W( 1 )
1498       LOGICAL            ISAME( 13 )
1499 *     .. External Functions ..
1500       LOGICAL            LZE, LZERES
1501       EXTERNAL           LZE, LZERES
1502 *     .. External Subroutines ..
1503       EXTERNAL           ZGERC, ZGERU, ZMAKE, ZMVCH
1504 *     .. Intrinsic Functions ..
1505       INTRINSIC          ABS, DCONJG, MAX, MIN
1506 *     .. Scalars in Common ..
1507       INTEGER            INFOT, NOUTC
1508       LOGICAL            LERR, OK
1509 *     .. Common blocks ..
1510       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
1511 *     .. Executable Statements ..
1512       CONJ = SNAME( 5: 5 ).EQ.'C'
1513 *     Define the number of arguments.
1514       NARGS = 9
1515 *
1516       NC = 0
1517       RESET = .TRUE.
1518       ERRMAX = RZERO
1519 *
1520       DO 120 IN = 1, NIDIM
1521          N = IDIM( IN )
1522          ND = N/2 + 1
1523 *
1524          DO 110 IM = 1, 2
1525             IF( IM.EQ.1 )
1526      $         M = MAX( N - ND, 0 )
1527             IF( IM.EQ.2 )
1528      $         M = MIN( N + ND, NMAX )
1529 *
1530 *           Set LDA to 1 more than minimum value if room.
1531             LDA = M
1532             IF( LDA.LT.NMAX )
1533      $         LDA = LDA + 1
1534 *           Skip tests if not enough room.
1535             IF( LDA.GT.NMAX )
1536      $         GO TO 110
1537             LAA = LDA*N
1538             NULL = N.LE.0.OR.M.LE.0
1539 *
1540             DO 100 IX = 1, NINC
1541                INCX = INC( IX )
1542                LX = ABS( INCX )*M
1543 *
1544 *              Generate the vector X.
1545 *
1546                TRANSL = HALF
1547                CALL ZMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ),
1548      $                     0, M - 1, RESET, TRANSL )
1549                IF( M.GT.1 )THEN
1550                   X( M/2 ) = ZERO
1551                   XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO
1552                END IF
1553 *
1554                DO 90 IY = 1, NINC
1555                   INCY = INC( IY )
1556                   LY = ABS( INCY )*N
1557 *
1558 *                 Generate the vector Y.
1559 *
1560                   TRANSL = ZERO
1561                   CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
1562      $                        ABS( INCY ), 0, N - 1, RESET, TRANSL )
1563                   IF( N.GT.1 )THEN
1564                      Y( N/2 ) = ZERO
1565                      YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
1566                   END IF
1567 *
1568                   DO 80 IA = 1, NALF
1569                      ALPHA = ALF( IA )
1570 *
1571 *                    Generate the matrix A.
1572 *
1573                      TRANSL = ZERO
1574                      CALL ZMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX,
1575      $                           AA, LDA, M - 1, N - 1, RESET, TRANSL )
1576 *
1577                      NC = NC + 1
1578 *
1579 *                    Save every datum before calling the subroutine.
1580 *
1581                      MS = M
1582                      NS = N
1583                      ALS = ALPHA
1584                      DO 10 I = 1, LAA
1585                         AS( I ) = AA( I )
1586    10                CONTINUE
1587                      LDAS = LDA
1588                      DO 20 I = 1, LX
1589                         XS( I ) = XX( I )
1590    20                CONTINUE
1591                      INCXS = INCX
1592                      DO 30 I = 1, LY
1593                         YS( I ) = YY( I )
1594    30                CONTINUE
1595                      INCYS = INCY
1596 *
1597 *                    Call the subroutine.
1598 *
1599                      IF( TRACE )
1600      $                  WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N,
1601      $                  ALPHA, INCX, INCY, LDA
1602                      IF( CONJ )THEN
1603                         IF( REWI )
1604      $                     REWIND NTRA
1605                         CALL ZGERC( M, N, ALPHA, XX, INCX, YY, INCY, AA,
1606      $                              LDA )
1607                      ELSE
1608                         IF( REWI )
1609      $                     REWIND NTRA
1610                         CALL ZGERU( M, N, ALPHA, XX, INCX, YY, INCY, AA,
1611      $                              LDA )
1612                      END IF
1613 *
1614 *                    Check if error-exit was taken incorrectly.
1615 *
1616                      IF( .NOT.OK )THEN
1617                         WRITE( NOUT, FMT = 9993 )
1618                         FATAL = .TRUE.
1619                         GO TO 140
1620                      END IF
1621 *
1622 *                    See what data changed inside subroutine.
1623 *
1624                      ISAME( 1 ) = MS.EQ.M
1625                      ISAME( 2 ) = NS.EQ.N
1626                      ISAME( 3 ) = ALS.EQ.ALPHA
1627                      ISAME( 4 ) = LZE( XS, XX, LX )
1628                      ISAME( 5 ) = INCXS.EQ.INCX
1629                      ISAME( 6 ) = LZE( YS, YY, LY )
1630                      ISAME( 7 ) = INCYS.EQ.INCY
1631                      IF( NULL )THEN
1632                         ISAME( 8 ) = LZE( AS, AA, LAA )
1633                      ELSE
1634                         ISAME( 8 ) = LZERES( 'GE', ' ', M, N, AS, AA,
1635      $                               LDA )
1636                      END IF
1637                      ISAME( 9 ) = LDAS.EQ.LDA
1638 *
1639 *                    If data was incorrectly changed, report and return.
1640 *
1641                      SAME = .TRUE.
1642                      DO 40 I = 1, NARGS
1643                         SAME = SAME.AND.ISAME( I )
1644                         IF( .NOT.ISAME( I ) )
1645      $                     WRITE( NOUT, FMT = 9998 )I
1646    40                CONTINUE
1647                      IF( .NOT.SAME )THEN
1648                         FATAL = .TRUE.
1649                         GO TO 140
1650                      END IF
1651 *
1652                      IF( .NOT.NULL )THEN
1653 *
1654 *                       Check the result column by column.
1655 *
1656                         IF( INCX.GT.0 )THEN
1657                            DO 50 I = 1, M
1658                               Z( I ) = X( I )
1659    50                      CONTINUE
1660                         ELSE
1661                            DO 60 I = 1, M
1662                               Z( I ) = X( M - I + 1 )
1663    60                      CONTINUE
1664                         END IF
1665                         DO 70 J = 1, N
1666                            IF( INCY.GT.0 )THEN
1667                               W( 1 ) = Y( J )
1668                            ELSE
1669                               W( 1 ) = Y( N - J + 1 )
1670                            END IF
1671                            IF( CONJ )
1672      $                        W( 1 ) = DCONJG( W( 1 ) )
1673                            CALL ZMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1,
1674      $                                 ONE, A( 1, J ), 1, YT, G,
1675      $                                 AA( 1 + ( J - 1 )*LDA ), EPS,
1676      $                                 ERR, FATAL, NOUT, .TRUE. )
1677                            ERRMAX = MAX( ERRMAX, ERR )
1678 *                          If got really bad answer, report and return.
1679                            IF( FATAL )
1680      $                        GO TO 130
1681    70                   CONTINUE
1682                      ELSE
1683 *                       Avoid repeating tests with M.le.0 or N.le.0.
1684                         GO TO 110
1685                      END IF
1686 *
1687    80             CONTINUE
1688 *
1689    90          CONTINUE
1690 *
1691   100       CONTINUE
1692 *
1693   110    CONTINUE
1694 *
1695   120 CONTINUE
1696 *
1697 *     Report result.
1698 *
1699       IF( ERRMAX.LT.THRESH )THEN
1700          WRITE( NOUT, FMT = 9999 )SNAME, NC
1701       ELSE
1702          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1703       END IF
1704       GO TO 150
1705 *
1706   130 CONTINUE
1707       WRITE( NOUT, FMT = 9995 )J
1708 *
1709   140 CONTINUE
1710       WRITE( NOUT, FMT = 9996 )SNAME
1711       WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA
1712 *
1713   150 CONTINUE
1714       RETURN
1715 *
1716  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1717      $      'S)' )
1718  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1719      $      'ANGED INCORRECTLY *******' )
1720  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1721      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1722      $      ' - SUSPECT *******' )
1723  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1724  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
1725  9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1,
1726      $      '), X,', I2, ', Y,', I2, ', A,', I3, ')                   ',
1727      $      '      .' )
1728  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1729      $      '******' )
1730 *
1731 *     End of ZCHK4.
1732 *
1733       END
1734       SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1735      $                  FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1736      $                  INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1737      $                  Z )
1738 *
1739 *  Tests ZHER and ZHPR.
1740 *
1741 *  Auxiliary routine for test program for Level 2 Blas.
1742 *
1743 *  -- Written on 10-August-1987.
1744 *     Richard Hanson, Sandia National Labs.
1745 *     Jeremy Du Croz, NAG Central Office.
1746 *
1747 *     .. Parameters ..
1748       COMPLEX*16         ZERO, HALF, ONE
1749       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
1750      $                   HALF = ( 0.5D0, 0.0D0 ),
1751      $                   ONE = ( 1.0D0, 0.0D0 ) )
1752       DOUBLE PRECISION   RZERO
1753       PARAMETER          ( RZERO = 0.0D0 )
1754 *     .. Scalar Arguments ..
1755       DOUBLE PRECISION   EPS, THRESH
1756       INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1757       LOGICAL            FATAL, REWI, TRACE
1758       CHARACTER*6        SNAME
1759 *     .. Array Arguments ..
1760       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1761      $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
1762      $                   XX( NMAX*INCMAX ), Y( NMAX ),
1763      $                   YS( NMAX*INCMAX ), YT( NMAX ),
1764      $                   YY( NMAX*INCMAX ), Z( NMAX )
1765       DOUBLE PRECISION   G( NMAX )
1766       INTEGER            IDIM( NIDIM ), INC( NINC )
1767 *     .. Local Scalars ..
1768       COMPLEX*16         ALPHA, TRANSL
1769       DOUBLE PRECISION   ERR, ERRMAX, RALPHA, RALS
1770       INTEGER            I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1771      $                   LDA, LDAS, LJ, LX, N, NARGS, NC, NS
1772       LOGICAL            FULL, NULL, PACKED, RESET, SAME, UPPER
1773       CHARACTER*1        UPLO, UPLOS
1774       CHARACTER*2        ICH
1775 *     .. Local Arrays ..
1776       COMPLEX*16         W( 1 )
1777       LOGICAL            ISAME( 13 )
1778 *     .. External Functions ..
1779       LOGICAL            LZE, LZERES
1780       EXTERNAL           LZE, LZERES
1781 *     .. External Subroutines ..
1782       EXTERNAL           ZHER, ZHPR, ZMAKE, ZMVCH
1783 *     .. Intrinsic Functions ..
1784       INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, MAX
1785 *     .. Scalars in Common ..
1786       INTEGER            INFOT, NOUTC
1787       LOGICAL            LERR, OK
1788 *     .. Common blocks ..
1789       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
1790 *     .. Data statements ..
1791       DATA               ICH/'UL'/
1792 *     .. Executable Statements ..
1793       FULL = SNAME( 3: 3 ).EQ.'E'
1794       PACKED = SNAME( 3: 3 ).EQ.'P'
1795 *     Define the number of arguments.
1796       IF( FULL )THEN
1797          NARGS = 7
1798       ELSE IF( PACKED )THEN
1799          NARGS = 6
1800       END IF
1801 *
1802       NC = 0
1803       RESET = .TRUE.
1804       ERRMAX = RZERO
1805 *
1806       DO 100 IN = 1, NIDIM
1807          N = IDIM( IN )
1808 *        Set LDA to 1 more than minimum value if room.
1809          LDA = N
1810          IF( LDA.LT.NMAX )
1811      $      LDA = LDA + 1
1812 *        Skip tests if not enough room.
1813          IF( LDA.GT.NMAX )
1814      $      GO TO 100
1815          IF( PACKED )THEN
1816             LAA = ( N*( N + 1 ) )/2
1817          ELSE
1818             LAA = LDA*N
1819          END IF
1820 *
1821          DO 90 IC = 1, 2
1822             UPLO = ICH( IC: IC )
1823             UPPER = UPLO.EQ.'U'
1824 *
1825             DO 80 IX = 1, NINC
1826                INCX = INC( IX )
1827                LX = ABS( INCX )*N
1828 *
1829 *              Generate the vector X.
1830 *
1831                TRANSL = HALF
1832                CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
1833      $                     0, N - 1, RESET, TRANSL )
1834                IF( N.GT.1 )THEN
1835                   X( N/2 ) = ZERO
1836                   XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1837                END IF
1838 *
1839                DO 70 IA = 1, NALF
1840                   RALPHA = DBLE( ALF( IA ) )
1841                   ALPHA = DCMPLX( RALPHA, RZERO )
1842                   NULL = N.LE.0.OR.RALPHA.EQ.RZERO
1843 *
1844 *                 Generate the matrix A.
1845 *
1846                   TRANSL = ZERO
1847                   CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX,
1848      $                        AA, LDA, N - 1, N - 1, RESET, TRANSL )
1849 *
1850                   NC = NC + 1
1851 *
1852 *                 Save every datum before calling the subroutine.
1853 *
1854                   UPLOS = UPLO
1855                   NS = N
1856                   RALS = RALPHA
1857                   DO 10 I = 1, LAA
1858                      AS( I ) = AA( I )
1859    10             CONTINUE
1860                   LDAS = LDA
1861                   DO 20 I = 1, LX
1862                      XS( I ) = XX( I )
1863    20             CONTINUE
1864                   INCXS = INCX
1865 *
1866 *                 Call the subroutine.
1867 *
1868                   IF( FULL )THEN
1869                      IF( TRACE )
1870      $                  WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
1871      $                  RALPHA, INCX, LDA
1872                      IF( REWI )
1873      $                  REWIND NTRA
1874                      CALL ZHER( UPLO, N, RALPHA, XX, INCX, AA, LDA )
1875                   ELSE IF( PACKED )THEN
1876                      IF( TRACE )
1877      $                  WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
1878      $                  RALPHA, INCX
1879                      IF( REWI )
1880      $                  REWIND NTRA
1881                      CALL ZHPR( UPLO, N, RALPHA, XX, INCX, AA )
1882                   END IF
1883 *
1884 *                 Check if error-exit was taken incorrectly.
1885 *
1886                   IF( .NOT.OK )THEN
1887                      WRITE( NOUT, FMT = 9992 )
1888                      FATAL = .TRUE.
1889                      GO TO 120
1890                   END IF
1891 *
1892 *                 See what data changed inside subroutines.
1893 *
1894                   ISAME( 1 ) = UPLO.EQ.UPLOS
1895                   ISAME( 2 ) = NS.EQ.N
1896                   ISAME( 3 ) = RALS.EQ.RALPHA
1897                   ISAME( 4 ) = LZE( XS, XX, LX )
1898                   ISAME( 5 ) = INCXS.EQ.INCX
1899                   IF( NULL )THEN
1900                      ISAME( 6 ) = LZE( AS, AA, LAA )
1901                   ELSE
1902                      ISAME( 6 ) = LZERES( SNAME( 2: 3 ), UPLO, N, N, AS,
1903      $                            AA, LDA )
1904                   END IF
1905                   IF( .NOT.PACKED )THEN
1906                      ISAME( 7 ) = LDAS.EQ.LDA
1907                   END IF
1908 *
1909 *                 If data was incorrectly changed, report and return.
1910 *
1911                   SAME = .TRUE.
1912                   DO 30 I = 1, NARGS
1913                      SAME = SAME.AND.ISAME( I )
1914                      IF( .NOT.ISAME( I ) )
1915      $                  WRITE( NOUT, FMT = 9998 )I
1916    30             CONTINUE
1917                   IF( .NOT.SAME )THEN
1918                      FATAL = .TRUE.
1919                      GO TO 120
1920                   END IF
1921 *
1922                   IF( .NOT.NULL )THEN
1923 *
1924 *                    Check the result column by column.
1925 *
1926                      IF( INCX.GT.0 )THEN
1927                         DO 40 I = 1, N
1928                            Z( I ) = X( I )
1929    40                   CONTINUE
1930                      ELSE
1931                         DO 50 I = 1, N
1932                            Z( I ) = X( N - I + 1 )
1933    50                   CONTINUE
1934                      END IF
1935                      JA = 1
1936                      DO 60 J = 1, N
1937                         W( 1 ) = DCONJG( Z( J ) )
1938                         IF( UPPER )THEN
1939                            JJ = 1
1940                            LJ = J
1941                         ELSE
1942                            JJ = J
1943                            LJ = N - J + 1
1944                         END IF
1945                         CALL ZMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W,
1946      $                              1, ONE, A( JJ, J ), 1, YT, G,
1947      $                              AA( JA ), EPS, ERR, FATAL, NOUT,
1948      $                              .TRUE. )
1949                         IF( FULL )THEN
1950                            IF( UPPER )THEN
1951                               JA = JA + LDA
1952                            ELSE
1953                               JA = JA + LDA + 1
1954                            END IF
1955                         ELSE
1956                            JA = JA + LJ
1957                         END IF
1958                         ERRMAX = MAX( ERRMAX, ERR )
1959 *                       If got really bad answer, report and return.
1960                         IF( FATAL )
1961      $                     GO TO 110
1962    60                CONTINUE
1963                   ELSE
1964 *                    Avoid repeating tests if N.le.0.
1965                      IF( N.LE.0 )
1966      $                  GO TO 100
1967                   END IF
1968 *
1969    70          CONTINUE
1970 *
1971    80       CONTINUE
1972 *
1973    90    CONTINUE
1974 *
1975   100 CONTINUE
1976 *
1977 *     Report result.
1978 *
1979       IF( ERRMAX.LT.THRESH )THEN
1980          WRITE( NOUT, FMT = 9999 )SNAME, NC
1981       ELSE
1982          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1983       END IF
1984       GO TO 130
1985 *
1986   110 CONTINUE
1987       WRITE( NOUT, FMT = 9995 )J
1988 *
1989   120 CONTINUE
1990       WRITE( NOUT, FMT = 9996 )SNAME
1991       IF( FULL )THEN
1992          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, RALPHA, INCX, LDA
1993       ELSE IF( PACKED )THEN
1994          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, RALPHA, INCX
1995       END IF
1996 *
1997   130 CONTINUE
1998       RETURN
1999 *
2000  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
2001      $      'S)' )
2002  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
2003      $      'ANGED INCORRECTLY *******' )
2004  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
2005      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
2006      $      ' - SUSPECT *******' )
2007  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
2008  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
2009  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
2010      $      I2, ', AP)                                         .' )
2011  9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
2012      $      I2, ', A,', I3, ')                                      .' )
2013  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2014      $      '******' )
2015 *
2016 *     End of ZCHK5.
2017 *
2018       END
2019       SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
2020      $                  FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
2021      $                  INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
2022      $                  Z )
2023 *
2024 *  Tests ZHER2 and ZHPR2.
2025 *
2026 *  Auxiliary routine for test program for Level 2 Blas.
2027 *
2028 *  -- Written on 10-August-1987.
2029 *     Richard Hanson, Sandia National Labs.
2030 *     Jeremy Du Croz, NAG Central Office.
2031 *
2032 *     .. Parameters ..
2033       COMPLEX*16         ZERO, HALF, ONE
2034       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
2035      $                   HALF = ( 0.5D0, 0.0D0 ),
2036      $                   ONE = ( 1.0D0, 0.0D0 ) )
2037       DOUBLE PRECISION   RZERO
2038       PARAMETER          ( RZERO = 0.0D0 )
2039 *     .. Scalar Arguments ..
2040       DOUBLE PRECISION   EPS, THRESH
2041       INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
2042       LOGICAL            FATAL, REWI, TRACE
2043       CHARACTER*6        SNAME
2044 *     .. Array Arguments ..
2045       COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2046      $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
2047      $                   XX( NMAX*INCMAX ), Y( NMAX ),
2048      $                   YS( NMAX*INCMAX ), YT( NMAX ),
2049      $                   YY( NMAX*INCMAX ), Z( NMAX, 2 )
2050       DOUBLE PRECISION   G( NMAX )
2051       INTEGER            IDIM( NIDIM ), INC( NINC )
2052 *     .. Local Scalars ..
2053       COMPLEX*16         ALPHA, ALS, TRANSL
2054       DOUBLE PRECISION   ERR, ERRMAX
2055       INTEGER            I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
2056      $                   IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
2057      $                   NARGS, NC, NS
2058       LOGICAL            FULL, NULL, PACKED, RESET, SAME, UPPER
2059       CHARACTER*1        UPLO, UPLOS
2060       CHARACTER*2        ICH
2061 *     .. Local Arrays ..
2062       COMPLEX*16         W( 2 )
2063       LOGICAL            ISAME( 13 )
2064 *     .. External Functions ..
2065       LOGICAL            LZE, LZERES
2066       EXTERNAL           LZE, LZERES
2067 *     .. External Subroutines ..
2068       EXTERNAL           ZHER2, ZHPR2, ZMAKE, ZMVCH
2069 *     .. Intrinsic Functions ..
2070       INTRINSIC          ABS, DCONJG, MAX
2071 *     .. Scalars in Common ..
2072       INTEGER            INFOT, NOUTC
2073       LOGICAL            LERR, OK
2074 *     .. Common blocks ..
2075       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
2076 *     .. Data statements ..
2077       DATA               ICH/'UL'/
2078 *     .. Executable Statements ..
2079       FULL = SNAME( 3: 3 ).EQ.'E'
2080       PACKED = SNAME( 3: 3 ).EQ.'P'
2081 *     Define the number of arguments.
2082       IF( FULL )THEN
2083          NARGS = 9
2084       ELSE IF( PACKED )THEN
2085          NARGS = 8
2086       END IF
2087 *
2088       NC = 0
2089       RESET = .TRUE.
2090       ERRMAX = RZERO
2091 *
2092       DO 140 IN = 1, NIDIM
2093          N = IDIM( IN )
2094 *        Set LDA to 1 more than minimum value if room.
2095          LDA = N
2096          IF( LDA.LT.NMAX )
2097      $      LDA = LDA + 1
2098 *        Skip tests if not enough room.
2099          IF( LDA.GT.NMAX )
2100      $      GO TO 140
2101          IF( PACKED )THEN
2102             LAA = ( N*( N + 1 ) )/2
2103          ELSE
2104             LAA = LDA*N
2105          END IF
2106 *
2107          DO 130 IC = 1, 2
2108             UPLO = ICH( IC: IC )
2109             UPPER = UPLO.EQ.'U'
2110 *
2111             DO 120 IX = 1, NINC
2112                INCX = INC( IX )
2113                LX = ABS( INCX )*N
2114 *
2115 *              Generate the vector X.
2116 *
2117                TRANSL = HALF
2118                CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
2119      $                     0, N - 1, RESET, TRANSL )
2120                IF( N.GT.1 )THEN
2121                   X( N/2 ) = ZERO
2122                   XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
2123                END IF
2124 *
2125                DO 110 IY = 1, NINC
2126                   INCY = INC( IY )
2127                   LY = ABS( INCY )*N
2128 *
2129 *                 Generate the vector Y.
2130 *
2131                   TRANSL = ZERO
2132                   CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
2133      $                        ABS( INCY ), 0, N - 1, RESET, TRANSL )
2134                   IF( N.GT.1 )THEN
2135                      Y( N/2 ) = ZERO
2136                      YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
2137                   END IF
2138 *
2139                   DO 100 IA = 1, NALF
2140                      ALPHA = ALF( IA )
2141                      NULL = N.LE.0.OR.ALPHA.EQ.ZERO
2142 *
2143 *                    Generate the matrix A.
2144 *
2145                      TRANSL = ZERO
2146                      CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A,
2147      $                           NMAX, AA, LDA, N - 1, N - 1, RESET,
2148      $                           TRANSL )
2149 *
2150                      NC = NC + 1
2151 *
2152 *                    Save every datum before calling the subroutine.
2153 *
2154                      UPLOS = UPLO
2155                      NS = N
2156                      ALS = ALPHA
2157                      DO 10 I = 1, LAA
2158                         AS( I ) = AA( I )
2159    10                CONTINUE
2160                      LDAS = LDA
2161                      DO 20 I = 1, LX
2162                         XS( I ) = XX( I )
2163    20                CONTINUE
2164                      INCXS = INCX
2165                      DO 30 I = 1, LY
2166                         YS( I ) = YY( I )
2167    30                CONTINUE
2168                      INCYS = INCY
2169 *
2170 *                    Call the subroutine.
2171 *
2172                      IF( FULL )THEN
2173                         IF( TRACE )
2174      $                     WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
2175      $                     ALPHA, INCX, INCY, LDA
2176                         IF( REWI )
2177      $                     REWIND NTRA
2178                         CALL ZHER2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
2179      $                              AA, LDA )
2180                      ELSE IF( PACKED )THEN
2181                         IF( TRACE )
2182      $                     WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
2183      $                     ALPHA, INCX, INCY
2184                         IF( REWI )
2185      $                     REWIND NTRA
2186                         CALL ZHPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
2187      $                              AA )
2188                      END IF
2189 *
2190 *                    Check if error-exit was taken incorrectly.
2191 *
2192                      IF( .NOT.OK )THEN
2193                         WRITE( NOUT, FMT = 9992 )
2194                         FATAL = .TRUE.
2195                         GO TO 160
2196                      END IF
2197 *
2198 *                    See what data changed inside subroutines.
2199 *
2200                      ISAME( 1 ) = UPLO.EQ.UPLOS
2201                      ISAME( 2 ) = NS.EQ.N
2202                      ISAME( 3 ) = ALS.EQ.ALPHA
2203                      ISAME( 4 ) = LZE( XS, XX, LX )
2204                      ISAME( 5 ) = INCXS.EQ.INCX
2205                      ISAME( 6 ) = LZE( YS, YY, LY )
2206                      ISAME( 7 ) = INCYS.EQ.INCY
2207                      IF( NULL )THEN
2208                         ISAME( 8 ) = LZE( AS, AA, LAA )
2209                      ELSE
2210                         ISAME( 8 ) = LZERES( SNAME( 2: 3 ), UPLO, N, N,
2211      $                               AS, AA, LDA )
2212                      END IF
2213                      IF( .NOT.PACKED )THEN
2214                         ISAME( 9 ) = LDAS.EQ.LDA
2215                      END IF
2216 *
2217 *                    If data was incorrectly changed, report and return.
2218 *
2219                      SAME = .TRUE.
2220                      DO 40 I = 1, NARGS
2221                         SAME = SAME.AND.ISAME( I )
2222                         IF( .NOT.ISAME( I ) )
2223      $                     WRITE( NOUT, FMT = 9998 )I
2224    40                CONTINUE
2225                      IF( .NOT.SAME )THEN
2226                         FATAL = .TRUE.
2227                         GO TO 160
2228                      END IF
2229 *
2230                      IF( .NOT.NULL )THEN
2231 *
2232 *                       Check the result column by column.
2233 *
2234                         IF( INCX.GT.0 )THEN
2235                            DO 50 I = 1, N
2236                               Z( I, 1 ) = X( I )
2237    50                      CONTINUE
2238                         ELSE
2239                            DO 60 I = 1, N
2240                               Z( I, 1 ) = X( N - I + 1 )
2241    60                      CONTINUE
2242                         END IF
2243                         IF( INCY.GT.0 )THEN
2244                            DO 70 I = 1, N
2245                               Z( I, 2 ) = Y( I )
2246    70                      CONTINUE
2247                         ELSE
2248                            DO 80 I = 1, N
2249                               Z( I, 2 ) = Y( N - I + 1 )
2250    80                      CONTINUE
2251                         END IF
2252                         JA = 1
2253                         DO 90 J = 1, N
2254                            W( 1 ) = ALPHA*DCONJG( Z( J, 2 ) )
2255                            W( 2 ) = DCONJG( ALPHA )*DCONJG( Z( J, 1 ) )
2256                            IF( UPPER )THEN
2257                               JJ = 1
2258                               LJ = J
2259                            ELSE
2260                               JJ = J
2261                               LJ = N - J + 1
2262                            END IF
2263                            CALL ZMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ),
2264      $                                 NMAX, W, 1, ONE, A( JJ, J ), 1,
2265      $                                 YT, G, AA( JA ), EPS, ERR, FATAL,
2266      $                                 NOUT, .TRUE. )
2267                            IF( FULL )THEN
2268                               IF( UPPER )THEN
2269                                  JA = JA + LDA
2270                               ELSE
2271                                  JA = JA + LDA + 1
2272                               END IF
2273                            ELSE
2274                               JA = JA + LJ
2275                            END IF
2276                            ERRMAX = MAX( ERRMAX, ERR )
2277 *                          If got really bad answer, report and return.
2278                            IF( FATAL )
2279      $                        GO TO 150
2280    90                   CONTINUE
2281                      ELSE
2282 *                       Avoid repeating tests with N.le.0.
2283                         IF( N.LE.0 )
2284      $                     GO TO 140
2285                      END IF
2286 *
2287   100             CONTINUE
2288 *
2289   110          CONTINUE
2290 *
2291   120       CONTINUE
2292 *
2293   130    CONTINUE
2294 *
2295   140 CONTINUE
2296 *
2297 *     Report result.
2298 *
2299       IF( ERRMAX.LT.THRESH )THEN
2300          WRITE( NOUT, FMT = 9999 )SNAME, NC
2301       ELSE
2302          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
2303       END IF
2304       GO TO 170
2305 *
2306   150 CONTINUE
2307       WRITE( NOUT, FMT = 9995 )J
2308 *
2309   160 CONTINUE
2310       WRITE( NOUT, FMT = 9996 )SNAME
2311       IF( FULL )THEN
2312          WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX,
2313      $      INCY, LDA
2314       ELSE IF( PACKED )THEN
2315          WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY
2316       END IF
2317 *
2318   170 CONTINUE
2319       RETURN
2320 *
2321  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
2322      $      'S)' )
2323  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
2324      $      'ANGED INCORRECTLY *******' )
2325  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
2326      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
2327      $      ' - SUSPECT *******' )
2328  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
2329  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
2330  9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
2331      $      F4.1, '), X,', I2, ', Y,', I2, ', AP)                     ',
2332      $      '       .' )
2333  9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
2334      $      F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ')             ',
2335      $      '            .' )
2336  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2337      $      '******' )
2338 *
2339 *     End of ZCHK6.
2340 *
2341       END
2342       SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT )
2343 *
2344 *  Tests the error exits from the Level 2 Blas.
2345 *  Requires a special version of the error-handling routine XERBLA.
2346 *  ALPHA, RALPHA, BETA, A, X and Y should not need to be defined.
2347 *
2348 *  Auxiliary routine for test program for Level 2 Blas.
2349 *
2350 *  -- Written on 10-August-1987.
2351 *     Richard Hanson, Sandia National Labs.
2352 *     Jeremy Du Croz, NAG Central Office.
2353 *
2354 *     .. Scalar Arguments ..
2355       INTEGER            ISNUM, NOUT
2356       CHARACTER*6        SRNAMT
2357 *     .. Scalars in Common ..
2358       INTEGER            INFOT, NOUTC
2359       LOGICAL            LERR, OK
2360 *     .. Local Scalars ..
2361       COMPLEX*16         ALPHA, BETA
2362       DOUBLE PRECISION   RALPHA
2363 *     .. Local Arrays ..
2364       COMPLEX*16         A( 1, 1 ), X( 1 ), Y( 1 )
2365 *     .. External Subroutines ..
2366       EXTERNAL           CHKXER, ZGBMV, ZGEMV, ZGERC, ZGERU, ZHBMV,
2367      $                   ZHEMV, ZHER, ZHER2, ZHPMV, ZHPR, ZHPR2, ZTBMV,
2368      $                   ZTBSV, ZTPMV, ZTPSV, ZTRMV, ZTRSV
2369 *     .. Common blocks ..
2370       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
2371 *     .. Executable Statements ..
2372 *     OK is set to .FALSE. by the special version of XERBLA or by CHKXER
2373 *     if anything is wrong.
2374       OK = .TRUE.
2375 *     LERR is set to .TRUE. by the special version of XERBLA each time
2376 *     it is called, and is then tested and re-set by CHKXER.
2377       LERR = .FALSE.
2378       GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
2379      $        90, 100, 110, 120, 130, 140, 150, 160,
2380      $        170 )ISNUM
2381    10 INFOT = 1
2382       CALL ZGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2383       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2384       INFOT = 2
2385       CALL ZGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2386       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2387       INFOT = 3
2388       CALL ZGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2389       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2390       INFOT = 6
2391       CALL ZGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2392       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2393       INFOT = 8
2394       CALL ZGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
2395       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2396       INFOT = 11
2397       CALL ZGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
2398       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2399       GO TO 180
2400    20 INFOT = 1
2401       CALL ZGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2402       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2403       INFOT = 2
2404       CALL ZGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2405       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2406       INFOT = 3
2407       CALL ZGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2408       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2409       INFOT = 4
2410       CALL ZGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2411       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2412       INFOT = 5
2413       CALL ZGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2414       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2415       INFOT = 8
2416       CALL ZGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2417       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2418       INFOT = 10
2419       CALL ZGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
2420       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2421       INFOT = 13
2422       CALL ZGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
2423       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2424       GO TO 180
2425    30 INFOT = 1
2426       CALL ZHEMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2427       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2428       INFOT = 2
2429       CALL ZHEMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2430       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2431       INFOT = 5
2432       CALL ZHEMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2433       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2434       INFOT = 7
2435       CALL ZHEMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
2436       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2437       INFOT = 10
2438       CALL ZHEMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
2439       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2440       GO TO 180
2441    40 INFOT = 1
2442       CALL ZHBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2443       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2444       INFOT = 2
2445       CALL ZHBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2446       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2447       INFOT = 3
2448       CALL ZHBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2449       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2450       INFOT = 6
2451       CALL ZHBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
2452       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2453       INFOT = 8
2454       CALL ZHBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
2455       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2456       INFOT = 11
2457       CALL ZHBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
2458       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2459       GO TO 180
2460    50 INFOT = 1
2461       CALL ZHPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 )
2462       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2463       INFOT = 2
2464       CALL ZHPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 )
2465       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2466       INFOT = 6
2467       CALL ZHPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 )
2468       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2469       INFOT = 9
2470       CALL ZHPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 )
2471       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2472       GO TO 180
2473    60 INFOT = 1
2474       CALL ZTRMV( '/', 'N', 'N', 0, A, 1, X, 1 )
2475       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2476       INFOT = 2
2477       CALL ZTRMV( 'U', '/', 'N', 0, A, 1, X, 1 )
2478       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2479       INFOT = 3
2480       CALL ZTRMV( 'U', 'N', '/', 0, A, 1, X, 1 )
2481       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2482       INFOT = 4
2483       CALL ZTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 )
2484       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2485       INFOT = 6
2486       CALL ZTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 )
2487       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2488       INFOT = 8
2489       CALL ZTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 )
2490       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2491       GO TO 180
2492    70 INFOT = 1
2493       CALL ZTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
2494       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2495       INFOT = 2
2496       CALL ZTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
2497       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2498       INFOT = 3
2499       CALL ZTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
2500       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2501       INFOT = 4
2502       CALL ZTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
2503       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2504       INFOT = 5
2505       CALL ZTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
2506       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2507       INFOT = 7
2508       CALL ZTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
2509       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2510       INFOT = 9
2511       CALL ZTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
2512       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2513       GO TO 180
2514    80 INFOT = 1
2515       CALL ZTPMV( '/', 'N', 'N', 0, A, X, 1 )
2516       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2517       INFOT = 2
2518       CALL ZTPMV( 'U', '/', 'N', 0, A, X, 1 )
2519       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2520       INFOT = 3
2521       CALL ZTPMV( 'U', 'N', '/', 0, A, X, 1 )
2522       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2523       INFOT = 4
2524       CALL ZTPMV( 'U', 'N', 'N', -1, A, X, 1 )
2525       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2526       INFOT = 7
2527       CALL ZTPMV( 'U', 'N', 'N', 0, A, X, 0 )
2528       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2529       GO TO 180
2530    90 INFOT = 1
2531       CALL ZTRSV( '/', 'N', 'N', 0, A, 1, X, 1 )
2532       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2533       INFOT = 2
2534       CALL ZTRSV( 'U', '/', 'N', 0, A, 1, X, 1 )
2535       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2536       INFOT = 3
2537       CALL ZTRSV( 'U', 'N', '/', 0, A, 1, X, 1 )
2538       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2539       INFOT = 4
2540       CALL ZTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 )
2541       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2542       INFOT = 6
2543       CALL ZTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 )
2544       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2545       INFOT = 8
2546       CALL ZTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 )
2547       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2548       GO TO 180
2549   100 INFOT = 1
2550       CALL ZTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
2551       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2552       INFOT = 2
2553       CALL ZTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
2554       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2555       INFOT = 3
2556       CALL ZTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
2557       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2558       INFOT = 4
2559       CALL ZTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
2560       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2561       INFOT = 5
2562       CALL ZTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
2563       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2564       INFOT = 7
2565       CALL ZTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
2566       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2567       INFOT = 9
2568       CALL ZTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
2569       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2570       GO TO 180
2571   110 INFOT = 1
2572       CALL ZTPSV( '/', 'N', 'N', 0, A, X, 1 )
2573       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2574       INFOT = 2
2575       CALL ZTPSV( 'U', '/', 'N', 0, A, X, 1 )
2576       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2577       INFOT = 3
2578       CALL ZTPSV( 'U', 'N', '/', 0, A, X, 1 )
2579       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2580       INFOT = 4
2581       CALL ZTPSV( 'U', 'N', 'N', -1, A, X, 1 )
2582       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2583       INFOT = 7
2584       CALL ZTPSV( 'U', 'N', 'N', 0, A, X, 0 )
2585       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2586       GO TO 180
2587   120 INFOT = 1
2588       CALL ZGERC( -1, 0, ALPHA, X, 1, Y, 1, A, 1 )
2589       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2590       INFOT = 2
2591       CALL ZGERC( 0, -1, ALPHA, X, 1, Y, 1, A, 1 )
2592       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2593       INFOT = 5
2594       CALL ZGERC( 0, 0, ALPHA, X, 0, Y, 1, A, 1 )
2595       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2596       INFOT = 7
2597       CALL ZGERC( 0, 0, ALPHA, X, 1, Y, 0, A, 1 )
2598       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2599       INFOT = 9
2600       CALL ZGERC( 2, 0, ALPHA, X, 1, Y, 1, A, 1 )
2601       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2602       GO TO 180
2603   130 INFOT = 1
2604       CALL ZGERU( -1, 0, ALPHA, X, 1, Y, 1, A, 1 )
2605       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2606       INFOT = 2
2607       CALL ZGERU( 0, -1, ALPHA, X, 1, Y, 1, A, 1 )
2608       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2609       INFOT = 5
2610       CALL ZGERU( 0, 0, ALPHA, X, 0, Y, 1, A, 1 )
2611       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2612       INFOT = 7
2613       CALL ZGERU( 0, 0, ALPHA, X, 1, Y, 0, A, 1 )
2614       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2615       INFOT = 9
2616       CALL ZGERU( 2, 0, ALPHA, X, 1, Y, 1, A, 1 )
2617       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2618       GO TO 180
2619   140 INFOT = 1
2620       CALL ZHER( '/', 0, RALPHA, X, 1, A, 1 )
2621       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2622       INFOT = 2
2623       CALL ZHER( 'U', -1, RALPHA, X, 1, A, 1 )
2624       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2625       INFOT = 5
2626       CALL ZHER( 'U', 0, RALPHA, X, 0, A, 1 )
2627       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2628       INFOT = 7
2629       CALL ZHER( 'U', 2, RALPHA, X, 1, A, 1 )
2630       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2631       GO TO 180
2632   150 INFOT = 1
2633       CALL ZHPR( '/', 0, RALPHA, X, 1, A )
2634       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2635       INFOT = 2
2636       CALL ZHPR( 'U', -1, RALPHA, X, 1, A )
2637       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2638       INFOT = 5
2639       CALL ZHPR( 'U', 0, RALPHA, X, 0, A )
2640       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2641       GO TO 180
2642   160 INFOT = 1
2643       CALL ZHER2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 )
2644       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2645       INFOT = 2
2646       CALL ZHER2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 )
2647       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2648       INFOT = 5
2649       CALL ZHER2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 )
2650       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2651       INFOT = 7
2652       CALL ZHER2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 )
2653       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2654       INFOT = 9
2655       CALL ZHER2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 )
2656       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2657       GO TO 180
2658   170 INFOT = 1
2659       CALL ZHPR2( '/', 0, ALPHA, X, 1, Y, 1, A )
2660       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2661       INFOT = 2
2662       CALL ZHPR2( 'U', -1, ALPHA, X, 1, Y, 1, A )
2663       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2664       INFOT = 5
2665       CALL ZHPR2( 'U', 0, ALPHA, X, 0, Y, 1, A )
2666       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2667       INFOT = 7
2668       CALL ZHPR2( 'U', 0, ALPHA, X, 1, Y, 0, A )
2669       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2670 *
2671   180 IF( OK )THEN
2672          WRITE( NOUT, FMT = 9999 )SRNAMT
2673       ELSE
2674          WRITE( NOUT, FMT = 9998 )SRNAMT
2675       END IF
2676       RETURN
2677 *
2678  9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
2679  9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
2680      $      '**' )
2681 *
2682 *     End of ZCHKE.
2683 *
2684       END
2685       SUBROUTINE ZMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
2686      $                  KU, RESET, TRANSL )
2687 *
2688 *  Generates values for an M by N matrix A within the bandwidth
2689 *  defined by KL and KU.
2690 *  Stores the values in the array AA in the data structure required
2691 *  by the routine, with unwanted elements set to rogue value.
2692 *
2693 *  TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'.
2694 *
2695 *  Auxiliary routine for test program for Level 2 Blas.
2696 *
2697 *  -- Written on 10-August-1987.
2698 *     Richard Hanson, Sandia National Labs.
2699 *     Jeremy Du Croz, NAG Central Office.
2700 *
2701 *     .. Parameters ..
2702       COMPLEX*16         ZERO, ONE
2703       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),
2704      $                   ONE = ( 1.0D0, 0.0D0 ) )
2705       COMPLEX*16         ROGUE
2706       PARAMETER          ( ROGUE = ( -1.0D10, 1.0D10 ) )
2707       DOUBLE PRECISION   RZERO
2708       PARAMETER          ( RZERO = 0.0D0 )
2709       DOUBLE PRECISION   RROGUE
2710       PARAMETER          ( RROGUE = -1.0D10 )
2711 *     .. Scalar Arguments ..
2712       COMPLEX*16         TRANSL
2713       INTEGER            KL, KU, LDA, M, N, NMAX
2714       LOGICAL            RESET
2715       CHARACTER*1        DIAG, UPLO
2716       CHARACTER*2        TYPE
2717 *     .. Array Arguments ..
2718       COMPLEX*16         A( NMAX, * ), AA( * )
2719 *     .. Local Scalars ..
2720       INTEGER            I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK
2721       LOGICAL            GEN, LOWER, SYM, TRI, UNIT, UPPER
2722 *     .. External Functions ..
2723       COMPLEX*16         ZBEG
2724       EXTERNAL           ZBEG
2725 *     .. Intrinsic Functions ..
2726       INTRINSIC          DBLE, DCMPLX, DCONJG, MAX, MIN
2727 *     .. Executable Statements ..
2728       GEN = TYPE( 1: 1 ).EQ.'G'
2729       SYM = TYPE( 1: 1 ).EQ.'H'
2730       TRI = TYPE( 1: 1 ).EQ.'T'
2731       UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
2732       LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
2733       UNIT = TRI.AND.DIAG.EQ.'U'
2734 *
2735 *     Generate data in array A.
2736 *
2737       DO 20 J = 1, N
2738          DO 10 I = 1, M
2739             IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
2740      $          THEN
2741                IF( ( I.LE.J.AND.J - I.LE.KU ).OR.
2742      $             ( I.GE.J.AND.I - J.LE.KL ) )THEN
2743                   A( I, J ) = ZBEG( RESET ) + TRANSL
2744                ELSE
2745                   A( I, J ) = ZERO
2746                END IF
2747                IF( I.NE.J )THEN
2748                   IF( SYM )THEN
2749                      A( J, I ) = DCONJG( A( I, J ) )
2750                   ELSE IF( TRI )THEN
2751                      A( J, I ) = ZERO
2752                   END IF
2753                END IF
2754             END IF
2755    10    CONTINUE
2756          IF( SYM )
2757      $      A( J, J ) = DCMPLX( DBLE( A( J, J ) ), RZERO )
2758          IF( TRI )
2759      $      A( J, J ) = A( J, J ) + ONE
2760          IF( UNIT )
2761      $      A( J, J ) = ONE
2762    20 CONTINUE
2763 *
2764 *     Store elements in array AS in data structure required by routine.
2765 *
2766       IF( TYPE.EQ.'GE' )THEN
2767          DO 50 J = 1, N
2768             DO 30 I = 1, M
2769                AA( I + ( J - 1 )*LDA ) = A( I, J )
2770    30       CONTINUE
2771             DO 40 I = M + 1, LDA
2772                AA( I + ( J - 1 )*LDA ) = ROGUE
2773    40       CONTINUE
2774    50    CONTINUE
2775       ELSE IF( TYPE.EQ.'GB' )THEN
2776          DO 90 J = 1, N
2777             DO 60 I1 = 1, KU + 1 - J
2778                AA( I1 + ( J - 1 )*LDA ) = ROGUE
2779    60       CONTINUE
2780             DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J )
2781                AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J )
2782    70       CONTINUE
2783             DO 80 I3 = I2, LDA
2784                AA( I3 + ( J - 1 )*LDA ) = ROGUE
2785    80       CONTINUE
2786    90    CONTINUE
2787       ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'TR' )THEN
2788          DO 130 J = 1, N
2789             IF( UPPER )THEN
2790                IBEG = 1
2791                IF( UNIT )THEN
2792                   IEND = J - 1
2793                ELSE
2794                   IEND = J
2795                END IF
2796             ELSE
2797                IF( UNIT )THEN
2798                   IBEG = J + 1
2799                ELSE
2800                   IBEG = J
2801                END IF
2802                IEND = N
2803             END IF
2804             DO 100 I = 1, IBEG - 1
2805                AA( I + ( J - 1 )*LDA ) = ROGUE
2806   100       CONTINUE
2807             DO 110 I = IBEG, IEND
2808                AA( I + ( J - 1 )*LDA ) = A( I, J )
2809   110       CONTINUE
2810             DO 120 I = IEND + 1, LDA
2811                AA( I + ( J - 1 )*LDA ) = ROGUE
2812   120       CONTINUE
2813             IF( SYM )THEN
2814                JJ = J + ( J - 1 )*LDA
2815                AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE )
2816             END IF
2817   130    CONTINUE
2818       ELSE IF( TYPE.EQ.'HB'.OR.TYPE.EQ.'TB' )THEN
2819          DO 170 J = 1, N
2820             IF( UPPER )THEN
2821                KK = KL + 1
2822                IBEG = MAX( 1, KL + 2 - J )
2823                IF( UNIT )THEN
2824                   IEND = KL
2825                ELSE
2826                   IEND = KL + 1
2827                END IF
2828             ELSE
2829                KK = 1
2830                IF( UNIT )THEN
2831                   IBEG = 2
2832                ELSE
2833                   IBEG = 1
2834                END IF
2835                IEND = MIN( KL + 1, 1 + M - J )
2836             END IF
2837             DO 140 I = 1, IBEG - 1
2838                AA( I + ( J - 1 )*LDA ) = ROGUE
2839   140       CONTINUE
2840             DO 150 I = IBEG, IEND
2841                AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J )
2842   150       CONTINUE
2843             DO 160 I = IEND + 1, LDA
2844                AA( I + ( J - 1 )*LDA ) = ROGUE
2845   160       CONTINUE
2846             IF( SYM )THEN
2847                JJ = KK + ( J - 1 )*LDA
2848                AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE )
2849             END IF
2850   170    CONTINUE
2851       ELSE IF( TYPE.EQ.'HP'.OR.TYPE.EQ.'TP' )THEN
2852          IOFF = 0
2853          DO 190 J = 1, N
2854             IF( UPPER )THEN
2855                IBEG = 1
2856                IEND = J
2857             ELSE
2858                IBEG = J
2859                IEND = N
2860             END IF
2861             DO 180 I = IBEG, IEND
2862                IOFF = IOFF + 1
2863                AA( IOFF ) = A( I, J )
2864                IF( I.EQ.J )THEN
2865                   IF( UNIT )
2866      $               AA( IOFF ) = ROGUE
2867                   IF( SYM )
2868      $               AA( IOFF ) = DCMPLX( DBLE( AA( IOFF ) ), RROGUE )
2869                END IF
2870   180       CONTINUE
2871   190    CONTINUE
2872       END IF
2873       RETURN
2874 *
2875 *     End of ZMAKE.
2876 *
2877       END
2878       SUBROUTINE ZMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
2879      $                  INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
2880 *
2881 *  Checks the results of the computational tests.
2882 *
2883 *  Auxiliary routine for test program for Level 2 Blas.
2884 *
2885 *  -- Written on 10-August-1987.
2886 *     Richard Hanson, Sandia National Labs.
2887 *     Jeremy Du Croz, NAG Central Office.
2888 *
2889 *     .. Parameters ..
2890       COMPLEX*16         ZERO
2891       PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ) )
2892       DOUBLE PRECISION   RZERO, RONE
2893       PARAMETER          ( RZERO = 0.0D0, RONE = 1.0D0 )
2894 *     .. Scalar Arguments ..
2895       COMPLEX*16         ALPHA, BETA
2896       DOUBLE PRECISION   EPS, ERR
2897       INTEGER            INCX, INCY, M, N, NMAX, NOUT
2898       LOGICAL            FATAL, MV
2899       CHARACTER*1        TRANS
2900 *     .. Array Arguments ..
2901       COMPLEX*16         A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * )
2902       DOUBLE PRECISION   G( * )
2903 *     .. Local Scalars ..
2904       COMPLEX*16         C
2905       DOUBLE PRECISION   ERRI
2906       INTEGER            I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
2907       LOGICAL            CTRAN, TRAN
2908 *     .. Intrinsic Functions ..
2909       INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, SQRT
2910 *     .. Statement Functions ..
2911       DOUBLE PRECISION   ABS1
2912 *     .. Statement Function definitions ..
2913       ABS1( C ) = ABS( DBLE( C ) ) + ABS( DIMAG( C ) )
2914 *     .. Executable Statements ..
2915       TRAN = TRANS.EQ.'T'
2916       CTRAN = TRANS.EQ.'C'
2917       IF( TRAN.OR.CTRAN )THEN
2918          ML = N
2919          NL = M
2920       ELSE
2921          ML = M
2922          NL = N
2923       END IF
2924       IF( INCX.LT.0 )THEN
2925          KX = NL
2926          INCXL = -1
2927       ELSE
2928          KX = 1
2929          INCXL = 1
2930       END IF
2931       IF( INCY.LT.0 )THEN
2932          KY = ML
2933          INCYL = -1
2934       ELSE
2935          KY = 1
2936          INCYL = 1
2937       END IF
2938 *
2939 *     Compute expected result in YT using data in A, X and Y.
2940 *     Compute gauges in G.
2941 *
2942       IY = KY
2943       DO 40 I = 1, ML
2944          YT( IY ) = ZERO
2945          G( IY ) = RZERO
2946          JX = KX
2947          IF( TRAN )THEN
2948             DO 10 J = 1, NL
2949                YT( IY ) = YT( IY ) + A( J, I )*X( JX )
2950                G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) )
2951                JX = JX + INCXL
2952    10       CONTINUE
2953          ELSE IF( CTRAN )THEN
2954             DO 20 J = 1, NL
2955                YT( IY ) = YT( IY ) + DCONJG( A( J, I ) )*X( JX )
2956                G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) )
2957                JX = JX + INCXL
2958    20       CONTINUE
2959          ELSE
2960             DO 30 J = 1, NL
2961                YT( IY ) = YT( IY ) + A( I, J )*X( JX )
2962                G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) )
2963                JX = JX + INCXL
2964    30       CONTINUE
2965          END IF
2966          YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY )
2967          G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) )
2968          IY = IY + INCYL
2969    40 CONTINUE
2970 *
2971 *     Compute the error ratio for this result.
2972 *
2973       ERR = ZERO
2974       DO 50 I = 1, ML
2975          ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS
2976          IF( G( I ).NE.RZERO )
2977      $      ERRI = ERRI/G( I )
2978          ERR = MAX( ERR, ERRI )
2979          IF( ERR*SQRT( EPS ).GE.RONE )
2980      $      GO TO 60
2981    50 CONTINUE
2982 *     If the loop completes, all results are at least half accurate.
2983       GO TO 80
2984 *
2985 *     Report fatal error.
2986 *
2987    60 FATAL = .TRUE.
2988       WRITE( NOUT, FMT = 9999 )
2989       DO 70 I = 1, ML
2990          IF( MV )THEN
2991             WRITE( NOUT, FMT = 9998 )I, YT( I ),
2992      $         YY( 1 + ( I - 1 )*ABS( INCY ) )
2993          ELSE
2994             WRITE( NOUT, FMT = 9998 )I,
2995      $         YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I )
2996          END IF
2997    70 CONTINUE
2998 *
2999    80 CONTINUE
3000       RETURN
3001 *
3002  9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3003      $      'F ACCURATE *******', /'                       EXPECTED RE',
3004      $      'SULT                    COMPUTED RESULT' )
3005  9998 FORMAT( 1X, I7, 2( '  (', G15.6, ',', G15.6, ')' ) )
3006 *
3007 *     End of ZMVCH.
3008 *
3009       END
3010       LOGICAL FUNCTION LZE( RI, RJ, LR )
3011 *
3012 *  Tests if two arrays are identical.
3013 *
3014 *  Auxiliary routine for test program for Level 2 Blas.
3015 *
3016 *  -- Written on 10-August-1987.
3017 *     Richard Hanson, Sandia National Labs.
3018 *     Jeremy Du Croz, NAG Central Office.
3019 *
3020 *     .. Scalar Arguments ..
3021       INTEGER            LR
3022 *     .. Array Arguments ..
3023       COMPLEX*16         RI( * ), RJ( * )
3024 *     .. Local Scalars ..
3025       INTEGER            I
3026 *     .. Executable Statements ..
3027       DO 10 I = 1, LR
3028          IF( RI( I ).NE.RJ( I ) )
3029      $      GO TO 20
3030    10 CONTINUE
3031       LZE = .TRUE.
3032       GO TO 30
3033    20 CONTINUE
3034       LZE = .FALSE.
3035    30 RETURN
3036 *
3037 *     End of LZE.
3038 *
3039       END
3040       LOGICAL FUNCTION LZERES( TYPE, UPLO, M, N, AA, AS, LDA )
3041 *
3042 *  Tests if selected elements in two arrays are equal.
3043 *
3044 *  TYPE is 'GE', 'HE' or 'HP'.
3045 *
3046 *  Auxiliary routine for test program for Level 2 Blas.
3047 *
3048 *  -- Written on 10-August-1987.
3049 *     Richard Hanson, Sandia National Labs.
3050 *     Jeremy Du Croz, NAG Central Office.
3051 *
3052 *     .. Scalar Arguments ..
3053       INTEGER            LDA, M, N
3054       CHARACTER*1        UPLO
3055       CHARACTER*2        TYPE
3056 *     .. Array Arguments ..
3057       COMPLEX*16         AA( LDA, * ), AS( LDA, * )
3058 *     .. Local Scalars ..
3059       INTEGER            I, IBEG, IEND, J
3060       LOGICAL            UPPER
3061 *     .. Executable Statements ..
3062       UPPER = UPLO.EQ.'U'
3063       IF( TYPE.EQ.'GE' )THEN
3064          DO 20 J = 1, N
3065             DO 10 I = M + 1, LDA
3066                IF( AA( I, J ).NE.AS( I, J ) )
3067      $            GO TO 70
3068    10       CONTINUE
3069    20    CONTINUE
3070       ELSE IF( TYPE.EQ.'HE' )THEN
3071          DO 50 J = 1, N
3072             IF( UPPER )THEN
3073                IBEG = 1
3074                IEND = J
3075             ELSE
3076                IBEG = J
3077                IEND = N
3078             END IF
3079             DO 30 I = 1, IBEG - 1
3080                IF( AA( I, J ).NE.AS( I, J ) )
3081      $            GO TO 70
3082    30       CONTINUE
3083             DO 40 I = IEND + 1, LDA
3084                IF( AA( I, J ).NE.AS( I, J ) )
3085      $            GO TO 70
3086    40       CONTINUE
3087    50    CONTINUE
3088       END IF
3089 *
3090    60 CONTINUE
3091       LZERES = .TRUE.
3092       GO TO 80
3093    70 CONTINUE
3094       LZERES = .FALSE.
3095    80 RETURN
3096 *
3097 *     End of LZERES.
3098 *
3099       END
3100       COMPLEX*16 FUNCTION ZBEG( RESET )
3101 *
3102 *  Generates complex numbers as pairs of random numbers uniformly
3103 *  distributed between -0.5 and 0.5.
3104 *
3105 *  Auxiliary routine for test program for Level 2 Blas.
3106 *
3107 *  -- Written on 10-August-1987.
3108 *     Richard Hanson, Sandia National Labs.
3109 *     Jeremy Du Croz, NAG Central Office.
3110 *
3111 *     .. Scalar Arguments ..
3112       LOGICAL            RESET
3113 *     .. Local Scalars ..
3114       INTEGER            I, IC, J, MI, MJ
3115 *     .. Save statement ..
3116       SAVE               I, IC, J, MI, MJ
3117 *     .. Intrinsic Functions ..
3118       INTRINSIC          DCMPLX
3119 *     .. Executable Statements ..
3120       IF( RESET )THEN
3121 *        Initialize local variables.
3122          MI = 891
3123          MJ = 457
3124          I = 7
3125          J = 7
3126          IC = 0
3127          RESET = .FALSE.
3128       END IF
3129 *
3130 *     The sequence of values of I or J is bounded between 1 and 999.
3131 *     If initial I or J = 1,2,3,6,7 or 9, the period will be 50.
3132 *     If initial I or J = 4 or 8, the period will be 25.
3133 *     If initial I or J = 5, the period will be 10.
3134 *     IC is used to break up the period by skipping 1 value of I or J
3135 *     in 6.
3136 *
3137       IC = IC + 1
3138    10 I = I*MI
3139       J = J*MJ
3140       I = I - 1000*( I/1000 )
3141       J = J - 1000*( J/1000 )
3142       IF( IC.GE.5 )THEN
3143          IC = 0
3144          GO TO 10
3145       END IF
3146       ZBEG = DCMPLX( ( I - 500 )/1001.0D0, ( J - 500 )/1001.0D0 )
3147       RETURN
3148 *
3149 *     End of ZBEG.
3150 *
3151       END
3152       DOUBLE PRECISION FUNCTION DDIFF( X, Y )
3153 *
3154 *  Auxiliary routine for test program for Level 2 Blas.
3155 *
3156 *  -- Written on 10-August-1987.
3157 *     Richard Hanson, Sandia National Labs.
3158 *
3159 *     .. Scalar Arguments ..
3160       DOUBLE PRECISION   X, Y
3161 *     .. Executable Statements ..
3162       DDIFF = X - Y
3163       RETURN
3164 *
3165 *     End of DDIFF.
3166 *
3167       END
3168       SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
3169 *
3170 *  Tests whether XERBLA has detected an error when it should.
3171 *
3172 *  Auxiliary routine for test program for Level 2 Blas.
3173 *
3174 *  -- Written on 10-August-1987.
3175 *     Richard Hanson, Sandia National Labs.
3176 *     Jeremy Du Croz, NAG Central Office.
3177 *
3178 *     .. Scalar Arguments ..
3179       INTEGER            INFOT, NOUT
3180       LOGICAL            LERR, OK
3181       CHARACTER*6        SRNAMT
3182 *     .. Executable Statements ..
3183       IF( .NOT.LERR )THEN
3184          WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
3185          OK = .FALSE.
3186       END IF
3187       LERR = .FALSE.
3188       RETURN
3189 *
3190  9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
3191      $      'ETECTED BY ', A6, ' *****' )
3192 *
3193 *     End of CHKXER.
3194 *
3195       END
3196       SUBROUTINE XERBLA( SRNAME, INFO )
3197 *
3198 *  This is a special version of XERBLA to be used only as part of
3199 *  the test program for testing error exits from the Level 2 BLAS
3200 *  routines.
3201 *
3202 *  XERBLA  is an error handler for the Level 2 BLAS routines.
3203 *
3204 *  It is called by the Level 2 BLAS routines if an input parameter is
3205 *  invalid.
3206 *
3207 *  Auxiliary routine for test program for Level 2 Blas.
3208 *
3209 *  -- Written on 10-August-1987.
3210 *     Richard Hanson, Sandia National Labs.
3211 *     Jeremy Du Croz, NAG Central Office.
3212 *
3213 *     .. Scalar Arguments ..
3214       INTEGER            INFO
3215       CHARACTER*6        SRNAME
3216 *     .. Scalars in Common ..
3217       INTEGER            INFOT, NOUT
3218       LOGICAL            LERR, OK
3219       CHARACTER*6        SRNAMT
3220 *     .. Common blocks ..
3221       COMMON             /INFOC/INFOT, NOUT, OK, LERR
3222       COMMON             /SRNAMC/SRNAMT
3223 *     .. Executable Statements ..
3224       LERR = .TRUE.
3225       IF( INFO.NE.INFOT )THEN
3226          IF( INFOT.NE.0 )THEN
3227             WRITE( NOUT, FMT = 9999 )INFO, INFOT
3228          ELSE
3229             WRITE( NOUT, FMT = 9997 )INFO
3230          END IF
3231          OK = .FALSE.
3232       END IF
3233       IF( SRNAME.NE.SRNAMT )THEN
3234          WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
3235          OK = .FALSE.
3236       END IF
3237       RETURN
3238 *
3239  9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
3240      $      ' OF ', I2, ' *******' )
3241  9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
3242      $      'AD OF ', A6, ' *******' )
3243  9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
3244      $      ' *******' )
3245 *
3246 *     End of XERBLA
3247 *
3248       END
3249