test/cblat3.f

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