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