ctest/c_zblat3.f

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