test/cblat3.f

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