test/cblat2.f

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