test/zblat3.f

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