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