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