ctest/c_cblat3.f

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