test/zblat2.f

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