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