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