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