LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
c_zblat3.f
Go to the documentation of this file.
1  PROGRAM zblat3
2 *
3 * Test program for the COMPLEX*16 Level 3 Blas.
4 *
5 * The program must be driven by a short data file. The first 13 records
6 * of the file are read using list-directed input, the last 9 records
7 * are read using the format ( A12,L2 ). An annotated example of a data
8 * file can be obtained by deleting the first 3 characters from the
9 * following 22 lines:
10 * 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
11 * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
12 * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
13 * F LOGICAL FLAG, T TO STOP ON FAILURES.
14 * T LOGICAL FLAG, T TO TEST ERROR EXITS.
15 * 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH
16 * 16.0 THRESHOLD VALUE OF TEST RATIO
17 * 6 NUMBER OF VALUES OF N
18 * 0 1 2 3 5 9 VALUES OF N
19 * 3 NUMBER OF VALUES OF ALPHA
20 * (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
21 * 3 NUMBER OF VALUES OF BETA
22 * (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
23 * ZGEMM T PUT F FOR NO TEST. SAME COLUMNS.
24 * ZHEMM T PUT F FOR NO TEST. SAME COLUMNS.
25 * ZSYMM T PUT F FOR NO TEST. SAME COLUMNS.
26 * ZTRMM T PUT F FOR NO TEST. SAME COLUMNS.
27 * ZTRSM T PUT F FOR NO TEST. SAME COLUMNS.
28 * ZHERK T PUT F FOR NO TEST. SAME COLUMNS.
29 * ZSYRK T PUT F FOR NO TEST. SAME COLUMNS.
30 * ZHER2K T PUT F FOR NO TEST. SAME COLUMNS.
31 * ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
32 *
33 * See:
34 *
35 * Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
36 * A Set of Level 3 Basic Linear Algebra Subprograms.
37 *
38 * Technical Memorandum No.88 (Revision 1), Mathematics and
39 * Computer Science Division, Argonne National Laboratory, 9700
40 * South Cass Avenue, Argonne, Illinois 60439, US.
41 *
42 * -- Written on 8-February-1989.
43 * Jack Dongarra, Argonne National Laboratory.
44 * Iain Duff, AERE Harwell.
45 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
46 * Sven Hammarling, Numerical Algorithms Group Ltd.
47 *
48 * .. Parameters ..
49  INTEGER NIN, NOUT
50  parameter ( nin = 5, nout = 6 )
51  INTEGER NSUBS
52  parameter ( nsubs = 9 )
53  COMPLEX*16 ZERO, ONE
54  parameter ( zero = ( 0.0d0, 0.0d0 ),
55  $ one = ( 1.0d0, 0.0d0 ) )
56  DOUBLE PRECISION RZERO, RHALF, RONE
57  parameter ( rzero = 0.0d0, rhalf = 0.5d0, rone = 1.0d0 )
58  INTEGER NMAX
59  parameter ( nmax = 65 )
60  INTEGER NIDMAX, NALMAX, NBEMAX
61  parameter ( nidmax = 9, nalmax = 7, nbemax = 7 )
62 * .. Local Scalars ..
63  DOUBLE PRECISION EPS, ERR, THRESH
64  INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NTRA,
65  $ layout
66  LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
67  $ tsterr, corder, rorder
68  CHARACTER*1 TRANSA, TRANSB
69  CHARACTER*12 SNAMET
70  CHARACTER*32 SNAPS
71 * .. Local Arrays ..
72  COMPLEX*16 AA( nmax*nmax ), AB( nmax, 2*nmax ),
73  $ alf( nalmax ), as( nmax*nmax ),
74  $ bb( nmax*nmax ), bet( nbemax ),
75  $ bs( nmax*nmax ), c( nmax, nmax ),
76  $ cc( nmax*nmax ), cs( nmax*nmax ), ct( nmax ),
77  $ w( 2*nmax )
78  DOUBLE PRECISION G( nmax )
79  INTEGER IDIM( nidmax )
80  LOGICAL LTEST( nsubs )
81  CHARACTER*12 SNAMES( nsubs )
82 * .. External Functions ..
83  DOUBLE PRECISION DDIFF
84  LOGICAL LZE
85  EXTERNAL ddiff, lze
86 * .. External Subroutines ..
87  EXTERNAL zchk1, zchk2, zchk3, zchk4, zchk5,zmmch
88 * .. Intrinsic Functions ..
89  INTRINSIC max, min
90 * .. Scalars in Common ..
91  INTEGER INFOT, NOUTC
92  LOGICAL LERR, OK
93  CHARACTER*12 SRNAMT
94 * .. Common blocks ..
95  COMMON /infoc/infot, noutc, ok, lerr
96  COMMON /srnamc/srnamt
97 * .. Data statements ..
98  DATA snames/'cblas_zgemm ', 'cblas_zhemm ',
99  $ 'cblas_zsymm ', 'cblas_ztrmm ', 'cblas_ztrsm ',
100  $ 'cblas_zherk ', 'cblas_zsyrk ', 'cblas_zher2k',
101  $ 'cblas_zsyr2k'/
102 * .. Executable Statements ..
103 *
104  noutc = nout
105 *
106 * Read name and unit number for snapshot output file and open file.
107 *
108  READ( nin, fmt = * )snaps
109  READ( nin, fmt = * )ntra
110  trace = ntra.GE.0
111  IF( trace )THEN
112  OPEN( ntra, file = snaps, status = 'NEW' )
113  END IF
114 * Read the flag that directs rewinding of the snapshot file.
115  READ( nin, fmt = * )rewi
116  rewi = rewi.AND.trace
117 * Read the flag that directs stopping on any failure.
118  READ( nin, fmt = * )sfatal
119 * Read the flag that indicates whether error exits are to be tested.
120  READ( nin, fmt = * )tsterr
121 * Read the flag that indicates whether row-major data layout to be tested.
122  READ( nin, fmt = * )layout
123 * Read the threshold value of the test ratio
124  READ( nin, fmt = * )thresh
125 *
126 * Read and check the parameter values for the tests.
127 *
128 * Values of N
129  READ( nin, fmt = * )nidim
130  IF( nidim.LT.1.OR.nidim.GT.nidmax )THEN
131  WRITE( nout, fmt = 9997 )'N', nidmax
132  GO TO 220
133  END IF
134  READ( nin, fmt = * )( idim( i ), i = 1, nidim )
135  DO 10 i = 1, nidim
136  IF( idim( i ).LT.0.OR.idim( i ).GT.nmax )THEN
137  WRITE( nout, fmt = 9996 )nmax
138  GO TO 220
139  END IF
140  10 CONTINUE
141 * Values of ALPHA
142  READ( nin, fmt = * )nalf
143  IF( nalf.LT.1.OR.nalf.GT.nalmax )THEN
144  WRITE( nout, fmt = 9997 )'ALPHA', nalmax
145  GO TO 220
146  END IF
147  READ( nin, fmt = * )( alf( i ), i = 1, nalf )
148 * Values of BETA
149  READ( nin, fmt = * )nbet
150  IF( nbet.LT.1.OR.nbet.GT.nbemax )THEN
151  WRITE( nout, fmt = 9997 )'BETA', nbemax
152  GO TO 220
153  END IF
154  READ( nin, fmt = * )( bet( i ), i = 1, nbet )
155 *
156 * Report values of parameters.
157 *
158  WRITE( nout, fmt = 9995 )
159  WRITE( nout, fmt = 9994 )( idim( i ), i = 1, nidim )
160  WRITE( nout, fmt = 9993 )( alf( i ), i = 1, nalf )
161  WRITE( nout, fmt = 9992 )( bet( i ), i = 1, nbet )
162  IF( .NOT.tsterr )THEN
163  WRITE( nout, fmt = * )
164  WRITE( nout, fmt = 9984 )
165  END IF
166  WRITE( nout, fmt = * )
167  WRITE( nout, fmt = 9999 )thresh
168  WRITE( nout, fmt = * )
169 
170  rorder = .false.
171  corder = .false.
172  IF (layout.EQ.2) THEN
173  rorder = .true.
174  corder = .true.
175  WRITE( *, fmt = 10002 )
176  ELSE IF (layout.EQ.1) THEN
177  rorder = .true.
178  WRITE( *, fmt = 10001 )
179  ELSE IF (layout.EQ.0) THEN
180  corder = .true.
181  WRITE( *, fmt = 10000 )
182  END IF
183  WRITE( *, fmt = * )
184 
185 *
186 * Read names of subroutines and flags which indicate
187 * whether they are to be tested.
188 *
189  DO 20 i = 1, nsubs
190  ltest( i ) = .false.
191  20 CONTINUE
192  30 READ( nin, fmt = 9988, end = 60 )snamet, ltestt
193  DO 40 i = 1, nsubs
194  IF( snamet.EQ.snames( i ) )
195  $ GO TO 50
196  40 CONTINUE
197  WRITE( nout, fmt = 9990 )snamet
198  stop
199  50 ltest( i ) = ltestt
200  GO TO 30
201 *
202  60 CONTINUE
203  CLOSE ( nin )
204 *
205 * Compute EPS (the machine precision).
206 *
207  eps = rone
208  70 CONTINUE
209  IF( ddiff( rone + eps, rone ).EQ.rzero )
210  $ GO TO 80
211  eps = rhalf*eps
212  GO TO 70
213  80 CONTINUE
214  eps = eps + eps
215  WRITE( nout, fmt = 9998 )eps
216 *
217 * Check the reliability of ZMMCH using exact data.
218 *
219  n = min( 32, nmax )
220  DO 100 j = 1, n
221  DO 90 i = 1, n
222  ab( i, j ) = max( i - j + 1, 0 )
223  90 CONTINUE
224  ab( j, nmax + 1 ) = j
225  ab( 1, nmax + j ) = j
226  c( j, 1 ) = zero
227  100 CONTINUE
228  DO 110 j = 1, n
229  cc( j ) = j*( ( j + 1 )*j )/2 - ( ( j + 1 )*j*( j - 1 ) )/3
230  110 CONTINUE
231 * CC holds the exact result. On exit from ZMMCH CT holds
232 * the result computed by ZMMCH.
233  transa = 'N'
234  transb = 'N'
235  CALL zmmch( transa, transb, n, 1, n, one, ab, nmax,
236  $ ab( 1, nmax + 1 ), nmax, zero, c, nmax, ct, g, cc,
237  $ nmax, eps, err, fatal, nout, .true. )
238  same = lze( cc, ct, n )
239  IF( .NOT.same.OR.err.NE.rzero )THEN
240  WRITE( nout, fmt = 9989 )transa, transb, same, err
241  stop
242  END IF
243  transb = 'C'
244  CALL zmmch( transa, transb, n, 1, n, one, ab, nmax,
245  $ ab( 1, nmax + 1 ), nmax, zero, c, nmax, ct, g, cc,
246  $ nmax, eps, err, fatal, nout, .true. )
247  same = lze( cc, ct, n )
248  IF( .NOT.same.OR.err.NE.rzero )THEN
249  WRITE( nout, fmt = 9989 )transa, transb, same, err
250  stop
251  END IF
252  DO 120 j = 1, n
253  ab( j, nmax + 1 ) = n - j + 1
254  ab( 1, nmax + j ) = n - j + 1
255  120 CONTINUE
256  DO 130 j = 1, n
257  cc( n - j + 1 ) = j*( ( j + 1 )*j )/2 -
258  $ ( ( j + 1 )*j*( j - 1 ) )/3
259  130 CONTINUE
260  transa = 'C'
261  transb = 'N'
262  CALL zmmch( transa, transb, n, 1, n, one, ab, nmax,
263  $ ab( 1, nmax + 1 ), nmax, zero, c, nmax, ct, g, cc,
264  $ nmax, eps, err, fatal, nout, .true. )
265  same = lze( cc, ct, n )
266  IF( .NOT.same.OR.err.NE.rzero )THEN
267  WRITE( nout, fmt = 9989 )transa, transb, same, err
268  stop
269  END IF
270  transb = 'C'
271  CALL zmmch( transa, transb, n, 1, n, one, ab, nmax,
272  $ ab( 1, nmax + 1 ), nmax, zero, c, nmax, ct, g, cc,
273  $ nmax, eps, err, fatal, nout, .true. )
274  same = lze( cc, ct, n )
275  IF( .NOT.same.OR.err.NE.rzero )THEN
276  WRITE( nout, fmt = 9989 )transa, transb, same, err
277  stop
278  END IF
279 *
280 * Test each subroutine in turn.
281 *
282  DO 200 isnum = 1, nsubs
283  WRITE( nout, fmt = * )
284  IF( .NOT.ltest( isnum ) )THEN
285 * Subprogram is not to be tested.
286  WRITE( nout, fmt = 9987 )snames( isnum )
287  ELSE
288  srnamt = snames( isnum )
289 * Test error exits.
290  IF( tsterr )THEN
291  CALL cz3chke( snames( isnum ) )
292  WRITE( nout, fmt = * )
293  END IF
294 * Test computations.
295  infot = 0
296  ok = .true.
297  fatal = .false.
298  GO TO ( 140, 150, 150, 160, 160, 170, 170,
299  $ 180, 180 )isnum
300 * Test ZGEMM, 01.
301  140 IF (corder) THEN
302  CALL zchk1(snames( isnum ), eps, thresh, nout, ntra, trace,
303  $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
304  $ nmax, ab, aa, as, ab( 1, nmax + 1 ), bb, bs, c,
305  $ cc, cs, ct, g, 0 )
306  END IF
307  IF (rorder) THEN
308  CALL zchk1(snames( isnum ), eps, thresh, nout, ntra, trace,
309  $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
310  $ nmax, ab, aa, as, ab( 1, nmax + 1 ), bb, bs, c,
311  $ cc, cs, ct, g, 1 )
312  END IF
313  GO TO 190
314 * Test ZHEMM, 02, ZSYMM, 03.
315  150 IF (corder) THEN
316  CALL zchk2(snames( isnum ), eps, thresh, nout, ntra, trace,
317  $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
318  $ nmax, ab, aa, as, ab( 1, nmax + 1 ), bb, bs, c,
319  $ cc, cs, ct, g, 0 )
320  END IF
321  IF (rorder) THEN
322  CALL zchk2(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, 1 )
326  END IF
327  GO TO 190
328 * Test ZTRMM, 04, ZTRSM, 05.
329  160 IF (corder) THEN
330  CALL zchk3(snames( isnum ), eps, thresh, nout, ntra, trace,
331  $ rewi, fatal, nidim, idim, nalf, alf, nmax, ab,
332  $ aa, as, ab( 1, nmax + 1 ), bb, bs, ct, g, c,
333  $ 0 )
334  END IF
335  IF (rorder) THEN
336  CALL zchk3(snames( isnum ), eps, thresh, nout, ntra, trace,
337  $ rewi, fatal, nidim, idim, nalf, alf, nmax, ab,
338  $ aa, as, ab( 1, nmax + 1 ), bb, bs, ct, g, c,
339  $ 1 )
340  END IF
341  GO TO 190
342 * Test ZHERK, 06, ZSYRK, 07.
343  170 IF (corder) THEN
344  CALL zchk4(snames( isnum ), eps, thresh, nout, ntra, trace,
345  $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
346  $ nmax, ab, aa, as, ab( 1, nmax + 1 ), bb, bs, c,
347  $ cc, cs, ct, g, 0 )
348  END IF
349  IF (rorder) THEN
350  CALL zchk4(snames( isnum ), eps, thresh, nout, ntra, trace,
351  $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
352  $ nmax, ab, aa, as, ab( 1, nmax + 1 ), bb, bs, c,
353  $ cc, cs, ct, g, 1 )
354  END IF
355  GO TO 190
356 * Test ZHER2K, 08, ZSYR2K, 09.
357  180 IF (corder) THEN
358  CALL zchk5(snames( isnum ), eps, thresh, nout, ntra, trace,
359  $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
360  $ nmax, ab, aa, as, bb, bs, c, cc, cs, ct, g, w,
361  $ 0 )
362  END IF
363  IF (rorder) THEN
364  CALL zchk5(snames( isnum ), eps, thresh, nout, ntra, trace,
365  $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
366  $ nmax, ab, aa, as, bb, bs, c, cc, cs, ct, g, w,
367  $ 1 )
368  END IF
369  GO TO 190
370 *
371  190 IF( fatal.AND.sfatal )
372  $ GO TO 210
373  END IF
374  200 CONTINUE
375  WRITE( nout, fmt = 9986 )
376  GO TO 230
377 *
378  210 CONTINUE
379  WRITE( nout, fmt = 9985 )
380  GO TO 230
381 *
382  220 CONTINUE
383  WRITE( nout, fmt = 9991 )
384 *
385  230 CONTINUE
386  IF( trace )
387  $ CLOSE ( ntra )
388  CLOSE ( nout )
389  stop
390 *
391 10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
392 10001 FORMAT(' ROW-MAJOR DATA LAYOUT IS TESTED' )
393 10000 FORMAT(' COLUMN-MAJOR DATA LAYOUT IS TESTED' )
394  9999 FORMAT(' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
395  $ 'S THAN', f8.2 )
396  9998 FORMAT(' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1p, e9.1 )
397  9997 FORMAT(' NUMBER OF VALUES OF ', a, ' IS LESS THAN 1 OR GREATER ',
398  $ 'THAN ', i2 )
399  9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', i2 )
400  9995 FORMAT('TESTS OF THE COMPLEX*16 LEVEL 3 BLAS', //' THE F',
401  $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
402  9994 FORMAT( ' FOR N ', 9i6 )
403  9993 FORMAT( ' FOR ALPHA ',
404  $ 7( '(', f4.1, ',', f4.1, ') ', : ) )
405  9992 FORMAT( ' FOR BETA ',
406  $ 7( '(', f4.1, ',', f4.1, ') ', : ) )
407  9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
408  $ /' ******* TESTS ABANDONED *******' )
409  9990 FORMAT(' SUBPROGRAM NAME ', a12,' NOT RECOGNIZED', /' ******* T',
410  $ 'ESTS ABANDONED *******' )
411  9989 FORMAT(' ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
412  $ 'ATED WRONGLY.', /' ZMMCH WAS CALLED WITH TRANSA = ', a1,
413  $ 'AND TRANSB = ', a1, /' AND RETURNED SAME = ', l1, ' AND ',
414  $ ' ERR = ', f12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
415  $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
416  $ '*******' )
417  9988 FORMAT( a12,l2 )
418  9987 FORMAT( 1x, a12,' WAS NOT TESTED' )
419  9986 FORMAT( /' END OF TESTS' )
420  9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
421  9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
422 *
423 * End of ZBLAT3.
424 *
425  END
426  SUBROUTINE zchk1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
427  $ fatal, nidim, idim, nalf, alf, nbet, bet, nmax,
428  $ a, aa, as, b, bb, bs, c, cc, cs, ct, g,
429  $ iorder )
430 *
431 * Tests ZGEMM.
432 *
433 * Auxiliary routine for test program for Level 3 Blas.
434 *
435 * -- Written on 8-February-1989.
436 * Jack Dongarra, Argonne National Laboratory.
437 * Iain Duff, AERE Harwell.
438 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
439 * Sven Hammarling, Numerical Algorithms Group Ltd.
440 *
441 * .. Parameters ..
442  COMPLEX*16 ZERO
443  parameter ( zero = ( 0.0, 0.0 ) )
444  DOUBLE PRECISION RZERO
445  parameter ( rzero = 0.0 )
446 * .. Scalar Arguments ..
447  DOUBLE PRECISION EPS, THRESH
448  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
449  LOGICAL FATAL, REWI, TRACE
450  CHARACTER*12 SNAME
451 * .. Array Arguments ..
452  COMPLEX*16 A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
453  $ as( nmax*nmax ), b( nmax, nmax ),
454  $ bb( nmax*nmax ), bet( nbet ), bs( nmax*nmax ),
455  $ c( nmax, nmax ), cc( nmax*nmax ),
456  $ cs( nmax*nmax ), ct( nmax )
457  DOUBLE PRECISION G( nmax )
458  INTEGER IDIM( nidim )
459 * .. Local Scalars ..
460  COMPLEX*16 ALPHA, ALS, BETA, BLS
461  DOUBLE PRECISION ERR, ERRMAX
462  INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
463  $ lbb, lcc, lda, ldas, ldb, ldbs, ldc, ldcs, m,
464  $ ma, mb, ms, n, na, nargs, nb, nc, ns
465  LOGICAL NULL, RESET, SAME, TRANA, TRANB
466  CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
467  CHARACTER*3 ICH
468 * .. Local Arrays ..
469  LOGICAL ISAME( 13 )
470 * .. External Functions ..
471  LOGICAL LZE, LZERES
472  EXTERNAL lze, lzeres
473 * .. External Subroutines ..
474  EXTERNAL czgemm, zmake, zmmch
475 * .. Intrinsic Functions ..
476  INTRINSIC max
477 * .. Scalars in Common ..
478  INTEGER INFOT, NOUTC
479  LOGICAL LERR, OK
480 * .. Common blocks ..
481  COMMON /infoc/infot, noutc, ok, lerr
482 * .. Data statements ..
483  DATA ich/'NTC'/
484 * .. Executable Statements ..
485 *
486  nargs = 13
487  nc = 0
488  reset = .true.
489  errmax = rzero
490 *
491  DO 110 im = 1, nidim
492  m = idim( im )
493 *
494  DO 100 in = 1, nidim
495  n = idim( in )
496 * Set LDC to 1 more than minimum value if room.
497  ldc = m
498  IF( ldc.LT.nmax )
499  $ ldc = ldc + 1
500 * Skip tests if not enough room.
501  IF( ldc.GT.nmax )
502  $ GO TO 100
503  lcc = ldc*n
504  null = n.LE.0.OR.m.LE.0
505 *
506  DO 90 ik = 1, nidim
507  k = idim( ik )
508 *
509  DO 80 ica = 1, 3
510  transa = ich( ica: ica )
511  trana = transa.EQ.'T'.OR.transa.EQ.'C'
512 *
513  IF( trana )THEN
514  ma = k
515  na = m
516  ELSE
517  ma = m
518  na = k
519  END IF
520 * Set LDA to 1 more than minimum value if room.
521  lda = ma
522  IF( lda.LT.nmax )
523  $ lda = lda + 1
524 * Skip tests if not enough room.
525  IF( lda.GT.nmax )
526  $ GO TO 80
527  laa = lda*na
528 *
529 * Generate the matrix A.
530 *
531  CALL zmake( 'ge', ' ', ' ', ma, na, a, nmax, aa, lda,
532  $ reset, zero )
533 *
534  DO 70 icb = 1, 3
535  transb = ich( icb: icb )
536  tranb = transb.EQ.'T'.OR.transb.EQ.'C'
537 *
538  IF( tranb )THEN
539  mb = n
540  nb = k
541  ELSE
542  mb = k
543  nb = n
544  END IF
545 * Set LDB to 1 more than minimum value if room.
546  ldb = mb
547  IF( ldb.LT.nmax )
548  $ ldb = ldb + 1
549 * Skip tests if not enough room.
550  IF( ldb.GT.nmax )
551  $ GO TO 70
552  lbb = ldb*nb
553 *
554 * Generate the matrix B.
555 *
556  CALL zmake( 'ge', ' ', ' ', mb, nb, b, nmax, bb,
557  $ ldb, reset, zero )
558 *
559  DO 60 ia = 1, nalf
560  alpha = alf( ia )
561 *
562  DO 50 ib = 1, nbet
563  beta = bet( ib )
564 *
565 * Generate the matrix C.
566 *
567  CALL zmake( 'ge', ' ', ' ', m, n, c, nmax,
568  $ cc, ldc, reset, zero )
569 *
570  nc = nc + 1
571 *
572 * Save every datum before calling the
573 * subroutine.
574 *
575  tranas = transa
576  tranbs = transb
577  ms = m
578  ns = n
579  ks = k
580  als = alpha
581  DO 10 i = 1, laa
582  as( i ) = aa( i )
583  10 CONTINUE
584  ldas = lda
585  DO 20 i = 1, lbb
586  bs( i ) = bb( i )
587  20 CONTINUE
588  ldbs = ldb
589  bls = beta
590  DO 30 i = 1, lcc
591  cs( i ) = cc( i )
592  30 CONTINUE
593  ldcs = ldc
594 *
595 * Call the subroutine.
596 *
597  IF( trace )
598  $ CALL zprcn1(ntra, nc, sname, iorder,
599  $ transa, transb, m, n, k, alpha, lda,
600  $ ldb, beta, ldc)
601  IF( rewi )
602  $ rewind ntra
603  CALL czgemm( iorder, transa, transb, m, n,
604  $ k, alpha, aa, lda, bb, ldb,
605  $ beta, cc, ldc )
606 *
607 * Check if error-exit was taken incorrectly.
608 *
609  IF( .NOT.ok )THEN
610  WRITE( nout, fmt = 9994 )
611  fatal = .true.
612  GO TO 120
613  END IF
614 *
615 * See what data changed inside subroutines.
616 *
617  isame( 1 ) = transa.EQ.tranas
618  isame( 2 ) = transb.EQ.tranbs
619  isame( 3 ) = ms.EQ.m
620  isame( 4 ) = ns.EQ.n
621  isame( 5 ) = ks.EQ.k
622  isame( 6 ) = als.EQ.alpha
623  isame( 7 ) = lze( as, aa, laa )
624  isame( 8 ) = ldas.EQ.lda
625  isame( 9 ) = lze( bs, bb, lbb )
626  isame( 10 ) = ldbs.EQ.ldb
627  isame( 11 ) = bls.EQ.beta
628  IF( null )THEN
629  isame( 12 ) = lze( cs, cc, lcc )
630  ELSE
631  isame( 12 ) = lzeres( 'ge', ' ', m, n, cs,
632  $ cc, ldc )
633  END IF
634  isame( 13 ) = ldcs.EQ.ldc
635 *
636 * If data was incorrectly changed, report
637 * and return.
638 *
639  same = .true.
640  DO 40 i = 1, nargs
641  same = same.AND.isame( i )
642  IF( .NOT.isame( i ) )
643  $ WRITE( nout, fmt = 9998 )i
644  40 CONTINUE
645  IF( .NOT.same )THEN
646  fatal = .true.
647  GO TO 120
648  END IF
649 *
650  IF( .NOT.null )THEN
651 *
652 * Check the result.
653 *
654  CALL zmmch( transa, transb, m, n, k,
655  $ alpha, a, nmax, b, nmax, beta,
656  $ c, nmax, ct, g, cc, ldc, eps,
657  $ err, fatal, nout, .true. )
658  errmax = max( errmax, err )
659 * If got really bad answer, report and
660 * return.
661  IF( fatal )
662  $ GO TO 120
663  END IF
664 *
665  50 CONTINUE
666 *
667  60 CONTINUE
668 *
669  70 CONTINUE
670 *
671  80 CONTINUE
672 *
673  90 CONTINUE
674 *
675  100 CONTINUE
676 *
677  110 CONTINUE
678 *
679 * Report result.
680 *
681  IF( errmax.LT.thresh )THEN
682  IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
683  IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
684  ELSE
685  IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
686  IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
687  END IF
688  GO TO 130
689 *
690  120 CONTINUE
691  WRITE( nout, fmt = 9996 )sname
692  CALL zprcn1(nout, nc, sname, iorder, transa, transb,
693  $ m, n, k, alpha, lda, ldb, beta, ldc)
694 *
695  130 CONTINUE
696  RETURN
697 *
698 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
699  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
700  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
701 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
702  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
703  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
704 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
705  $ ' (', i6, ' CALL', 'S)' )
706 10000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
707  $ ' (', i6, ' CALL', 'S)' )
708  9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
709  $ 'ANGED INCORRECTLY *******' )
710  9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
711  9995 FORMAT( 1x, i6, ': ', a12,'(''', a1, ''',''', a1, ''',',
712  $ 3( i3, ',' ), '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3,
713  $ ',(', f4.1, ',', f4.1, '), C,', i3, ').' )
714  9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
715  $ '******' )
716 *
717 * End of ZCHK1.
718 *
719  END
720 *
721  SUBROUTINE zprcn1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N,
722  $ k, alpha, lda, ldb, beta, ldc)
723  INTEGER NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC
724  DOUBLE COMPLEX ALPHA, BETA
725  CHARACTER*1 TRANSA, TRANSB
726  CHARACTER*12 SNAME
727  CHARACTER*14 CRC, CTA,CTB
728 
729  IF (transa.EQ.'N')THEN
730  cta = ' CblasNoTrans'
731  ELSE IF (transa.EQ.'T')THEN
732  cta = ' CblasTrans'
733  ELSE
734  cta = 'CblasConjTrans'
735  END IF
736  IF (transb.EQ.'N')THEN
737  ctb = ' CblasNoTrans'
738  ELSE IF (transb.EQ.'T')THEN
739  ctb = ' CblasTrans'
740  ELSE
741  ctb = 'CblasConjTrans'
742  END IF
743  IF (iorder.EQ.1)THEN
744  crc = ' CblasRowMajor'
745  ELSE
746  crc = ' CblasColMajor'
747  END IF
748  WRITE(nout, fmt = 9995)nc,sname,crc, cta,ctb
749  WRITE(nout, fmt = 9994)m, n, k, alpha, lda, ldb, beta, ldc
750 
751  9995 FORMAT( 1x, i6, ': ', a12,'(', a14, ',', a14, ',', a14, ',')
752  9994 FORMAT( 10x, 3( i3, ',' ) ,' (', f4.1,',',f4.1,') , A,',
753  $ i3, ', B,', i3, ', (', f4.1,',',f4.1,') , C,', i3, ').' )
754  END
755 *
756  SUBROUTINE zchk2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
757  $ fatal, nidim, idim, nalf, alf, nbet, bet, nmax,
758  $ a, aa, as, b, bb, bs, c, cc, cs, ct, g,
759  $ iorder )
760 *
761 * Tests ZHEMM and ZSYMM.
762 *
763 * Auxiliary routine for test program for Level 3 Blas.
764 *
765 * -- Written on 8-February-1989.
766 * Jack Dongarra, Argonne National Laboratory.
767 * Iain Duff, AERE Harwell.
768 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
769 * Sven Hammarling, Numerical Algorithms Group Ltd.
770 *
771 * .. Parameters ..
772  COMPLEX*16 ZERO
773  parameter ( zero = ( 0.0d0, 0.0d0 ) )
774  DOUBLE PRECISION RZERO
775  parameter ( rzero = 0.0d0 )
776 * .. Scalar Arguments ..
777  DOUBLE PRECISION EPS, THRESH
778  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
779  LOGICAL FATAL, REWI, TRACE
780  CHARACTER*12 SNAME
781 * .. Array Arguments ..
782  COMPLEX*16 A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
783  $ as( nmax*nmax ), b( nmax, nmax ),
784  $ bb( nmax*nmax ), bet( nbet ), bs( nmax*nmax ),
785  $ c( nmax, nmax ), cc( nmax*nmax ),
786  $ cs( nmax*nmax ), ct( nmax )
787  DOUBLE PRECISION G( nmax )
788  INTEGER IDIM( nidim )
789 * .. Local Scalars ..
790  COMPLEX*16 ALPHA, ALS, BETA, BLS
791  DOUBLE PRECISION ERR, ERRMAX
792  INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
793  $ lda, ldas, ldb, ldbs, ldc, ldcs, m, ms, n, na,
794  $ nargs, nc, ns
795  LOGICAL CONJ, LEFT, NULL, RESET, SAME
796  CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
797  CHARACTER*2 ICHS, ICHU
798 * .. Local Arrays ..
799  LOGICAL ISAME( 13 )
800 * .. External Functions ..
801  LOGICAL LZE, LZERES
802  EXTERNAL lze, lzeres
803 * .. External Subroutines ..
804  EXTERNAL czhemm, zmake, zmmch, czsymm
805 * .. Intrinsic Functions ..
806  INTRINSIC max
807 * .. Scalars in Common ..
808  INTEGER INFOT, NOUTC
809  LOGICAL LERR, OK
810 * .. Common blocks ..
811  COMMON /infoc/infot, noutc, ok, lerr
812 * .. Data statements ..
813  DATA ichs/'LR'/, ichu/'UL'/
814 * .. Executable Statements ..
815  conj = sname( 8: 9 ).EQ.'he'
816 *
817  nargs = 12
818  nc = 0
819  reset = .true.
820  errmax = rzero
821 *
822  DO 100 im = 1, nidim
823  m = idim( im )
824 *
825  DO 90 in = 1, nidim
826  n = idim( in )
827 * Set LDC to 1 more than minimum value if room.
828  ldc = m
829  IF( ldc.LT.nmax )
830  $ ldc = ldc + 1
831 * Skip tests if not enough room.
832  IF( ldc.GT.nmax )
833  $ GO TO 90
834  lcc = ldc*n
835  null = n.LE.0.OR.m.LE.0
836 * Set LDB to 1 more than minimum value if room.
837  ldb = m
838  IF( ldb.LT.nmax )
839  $ ldb = ldb + 1
840 * Skip tests if not enough room.
841  IF( ldb.GT.nmax )
842  $ GO TO 90
843  lbb = ldb*n
844 *
845 * Generate the matrix B.
846 *
847  CALL zmake( 'ge', ' ', ' ', m, n, b, nmax, bb, ldb, reset,
848  $ zero )
849 *
850  DO 80 ics = 1, 2
851  side = ichs( ics: ics )
852  left = side.EQ.'L'
853 *
854  IF( left )THEN
855  na = m
856  ELSE
857  na = n
858  END IF
859 * Set LDA to 1 more than minimum value if room.
860  lda = na
861  IF( lda.LT.nmax )
862  $ lda = lda + 1
863 * Skip tests if not enough room.
864  IF( lda.GT.nmax )
865  $ GO TO 80
866  laa = lda*na
867 *
868  DO 70 icu = 1, 2
869  uplo = ichu( icu: icu )
870 *
871 * Generate the hermitian or symmetric matrix A.
872 *
873  CALL zmake(sname( 8: 9 ), uplo, ' ', na, na, a, nmax,
874  $ aa, lda, reset, zero )
875 *
876  DO 60 ia = 1, nalf
877  alpha = alf( ia )
878 *
879  DO 50 ib = 1, nbet
880  beta = bet( ib )
881 *
882 * Generate the matrix C.
883 *
884  CALL zmake( 'ge', ' ', ' ', m, n, c, nmax, cc,
885  $ ldc, reset, zero )
886 *
887  nc = nc + 1
888 *
889 * Save every datum before calling the
890 * subroutine.
891 *
892  sides = side
893  uplos = uplo
894  ms = m
895  ns = n
896  als = alpha
897  DO 10 i = 1, laa
898  as( i ) = aa( i )
899  10 CONTINUE
900  ldas = lda
901  DO 20 i = 1, lbb
902  bs( i ) = bb( i )
903  20 CONTINUE
904  ldbs = ldb
905  bls = beta
906  DO 30 i = 1, lcc
907  cs( i ) = cc( i )
908  30 CONTINUE
909  ldcs = ldc
910 *
911 * Call the subroutine.
912 *
913  IF( trace )
914  $ CALL zprcn2(ntra, nc, sname, iorder,
915  $ side, uplo, m, n, alpha, lda, ldb,
916  $ beta, ldc)
917  IF( rewi )
918  $ rewind ntra
919  IF( conj )THEN
920  CALL czhemm( iorder, side, uplo, m, n,
921  $ alpha, aa, lda, bb, ldb, beta,
922  $ cc, ldc )
923  ELSE
924  CALL czsymm( iorder, side, uplo, m, n,
925  $ alpha, aa, lda, bb, ldb, beta,
926  $ cc, ldc )
927  END IF
928 *
929 * Check if error-exit was taken incorrectly.
930 *
931  IF( .NOT.ok )THEN
932  WRITE( nout, fmt = 9994 )
933  fatal = .true.
934  GO TO 110
935  END IF
936 *
937 * See what data changed inside subroutines.
938 *
939  isame( 1 ) = sides.EQ.side
940  isame( 2 ) = uplos.EQ.uplo
941  isame( 3 ) = ms.EQ.m
942  isame( 4 ) = ns.EQ.n
943  isame( 5 ) = als.EQ.alpha
944  isame( 6 ) = lze( as, aa, laa )
945  isame( 7 ) = ldas.EQ.lda
946  isame( 8 ) = lze( bs, bb, lbb )
947  isame( 9 ) = ldbs.EQ.ldb
948  isame( 10 ) = bls.EQ.beta
949  IF( null )THEN
950  isame( 11 ) = lze( cs, cc, lcc )
951  ELSE
952  isame( 11 ) = lzeres( 'ge', ' ', m, n, cs,
953  $ cc, ldc )
954  END IF
955  isame( 12 ) = ldcs.EQ.ldc
956 *
957 * If data was incorrectly changed, report and
958 * return.
959 *
960  same = .true.
961  DO 40 i = 1, nargs
962  same = same.AND.isame( i )
963  IF( .NOT.isame( i ) )
964  $ WRITE( nout, fmt = 9998 )i
965  40 CONTINUE
966  IF( .NOT.same )THEN
967  fatal = .true.
968  GO TO 110
969  END IF
970 *
971  IF( .NOT.null )THEN
972 *
973 * Check the result.
974 *
975  IF( left )THEN
976  CALL zmmch( 'N', 'N', m, n, m, alpha, a,
977  $ nmax, b, nmax, beta, c, nmax,
978  $ ct, g, cc, ldc, eps, err,
979  $ fatal, nout, .true. )
980  ELSE
981  CALL zmmch( 'N', 'N', m, n, n, alpha, b,
982  $ nmax, a, nmax, beta, c, nmax,
983  $ ct, g, cc, ldc, eps, err,
984  $ fatal, nout, .true. )
985  END IF
986  errmax = max( errmax, err )
987 * If got really bad answer, report and
988 * return.
989  IF( fatal )
990  $ GO TO 110
991  END IF
992 *
993  50 CONTINUE
994 *
995  60 CONTINUE
996 *
997  70 CONTINUE
998 *
999  80 CONTINUE
1000 *
1001  90 CONTINUE
1002 *
1003  100 CONTINUE
1004 *
1005 * Report result.
1006 *
1007  IF( errmax.LT.thresh )THEN
1008  IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
1009  IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
1010  ELSE
1011  IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
1012  IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
1013  END IF
1014  GO TO 120
1015 *
1016  110 CONTINUE
1017  WRITE( nout, fmt = 9996 )sname
1018  CALL zprcn2(nout, nc, sname, iorder, side, uplo, m, n, alpha, lda,
1019  $ ldb, beta, ldc)
1020 *
1021  120 CONTINUE
1022  RETURN
1023 *
1024 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1025  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1026  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1027 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1028  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1029  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1030 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1031  $ ' (', i6, ' CALL', 'S)' )
1032 10000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1033  $ ' (', i6, ' CALL', 'S)' )
1034  9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1035  $ 'ANGED INCORRECTLY *******' )
1036  9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
1037  9995 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1038  $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',(', f4.1,
1039  $ ',', f4.1, '), C,', i3, ') .' )
1040  9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1041  $ '******' )
1042 *
1043 * End of ZCHK2.
1044 *
1045  END
1046 *
1047  SUBROUTINE zprcn2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N,
1048  $ alpha, lda, ldb, beta, ldc)
1049  INTEGER NOUT, NC, IORDER, M, N, LDA, LDB, LDC
1050  DOUBLE COMPLEX ALPHA, BETA
1051  CHARACTER*1 SIDE, UPLO
1052  CHARACTER*12 SNAME
1053  CHARACTER*14 CRC, CS,CU
1054 
1055  IF (side.EQ.'L')THEN
1056  cs = ' CblasLeft'
1057  ELSE
1058  cs = ' CblasRight'
1059  END IF
1060  IF (uplo.EQ.'U')THEN
1061  cu = ' CblasUpper'
1062  ELSE
1063  cu = ' CblasLower'
1064  END IF
1065  IF (iorder.EQ.1)THEN
1066  crc = ' CblasRowMajor'
1067  ELSE
1068  crc = ' CblasColMajor'
1069  END IF
1070  WRITE(nout, fmt = 9995)nc,sname,crc, cs,cu
1071  WRITE(nout, fmt = 9994)m, n, alpha, lda, ldb, beta, ldc
1072 
1073  9995 FORMAT( 1x, i6, ': ', a12,'(', a14, ',', a14, ',', a14, ',')
1074  9994 FORMAT( 10x, 2( i3, ',' ),' (',f4.1,',',f4.1, '), A,', i3,
1075  $ ', B,', i3, ', (',f4.1,',',f4.1, '), ', 'C,', i3, ').' )
1076  END
1077 *
1078  SUBROUTINE zchk3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1079  $ fatal, nidim, idim, nalf, alf, nmax, a, aa, as,
1080  $ b, bb, bs, ct, g, c, iorder )
1081 *
1082 * Tests ZTRMM and ZTRSM.
1083 *
1084 * Auxiliary routine for test program for Level 3 Blas.
1085 *
1086 * -- Written on 8-February-1989.
1087 * Jack Dongarra, Argonne National Laboratory.
1088 * Iain Duff, AERE Harwell.
1089 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1090 * Sven Hammarling, Numerical Algorithms Group Ltd.
1091 *
1092 * .. Parameters ..
1093  COMPLEX*16 ZERO, ONE
1094  parameter ( zero = ( 0.0d0, 0.0d0 ), one = ( 1.0d0, 0.0d0 ) )
1095  DOUBLE PRECISION RZERO
1096  parameter ( rzero = 0.0d0 )
1097 * .. Scalar Arguments ..
1098  DOUBLE PRECISION EPS, THRESH
1099  INTEGER NALF, NIDIM, NMAX, NOUT, NTRA, IORDER
1100  LOGICAL FATAL, REWI, TRACE
1101  CHARACTER*12 SNAME
1102 * .. Array Arguments ..
1103  COMPLEX*16 A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
1104  $ as( nmax*nmax ), b( nmax, nmax ),
1105  $ bb( nmax*nmax ), bs( nmax*nmax ),
1106  $ c( nmax, nmax ), ct( nmax )
1107  DOUBLE PRECISION G( nmax )
1108  INTEGER IDIM( nidim )
1109 * .. Local Scalars ..
1110  COMPLEX*16 ALPHA, ALS
1111  DOUBLE PRECISION ERR, ERRMAX
1112  INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
1113  $ lda, ldas, ldb, ldbs, m, ms, n, na, nargs, nc,
1114  $ ns
1115  LOGICAL LEFT, NULL, RESET, SAME
1116  CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
1117  $ uplos
1118  CHARACTER*2 ICHD, ICHS, ICHU
1119  CHARACTER*3 ICHT
1120 * .. Local Arrays ..
1121  LOGICAL ISAME( 13 )
1122 * .. External Functions ..
1123  LOGICAL LZE, LZERES
1124  EXTERNAL lze, lzeres
1125 * .. External Subroutines ..
1126  EXTERNAL zmake, zmmch, cztrmm, cztrsm
1127 * .. Intrinsic Functions ..
1128  INTRINSIC max
1129 * .. Scalars in Common ..
1130  INTEGER INFOT, NOUTC
1131  LOGICAL LERR, OK
1132 * .. Common blocks ..
1133  COMMON /infoc/infot, noutc, ok, lerr
1134 * .. Data statements ..
1135  DATA ichu/'UL'/, icht/'NTC'/, ichd/'UN'/, ichs/'LR'/
1136 * .. Executable Statements ..
1137 *
1138  nargs = 11
1139  nc = 0
1140  reset = .true.
1141  errmax = rzero
1142 * Set up zero matrix for ZMMCH.
1143  DO 20 j = 1, nmax
1144  DO 10 i = 1, nmax
1145  c( i, j ) = zero
1146  10 CONTINUE
1147  20 CONTINUE
1148 *
1149  DO 140 im = 1, nidim
1150  m = idim( im )
1151 *
1152  DO 130 in = 1, nidim
1153  n = idim( in )
1154 * Set LDB to 1 more than minimum value if room.
1155  ldb = m
1156  IF( ldb.LT.nmax )
1157  $ ldb = ldb + 1
1158 * Skip tests if not enough room.
1159  IF( ldb.GT.nmax )
1160  $ GO TO 130
1161  lbb = ldb*n
1162  null = m.LE.0.OR.n.LE.0
1163 *
1164  DO 120 ics = 1, 2
1165  side = ichs( ics: ics )
1166  left = side.EQ.'L'
1167  IF( left )THEN
1168  na = m
1169  ELSE
1170  na = n
1171  END IF
1172 * Set LDA to 1 more than minimum value if room.
1173  lda = na
1174  IF( lda.LT.nmax )
1175  $ lda = lda + 1
1176 * Skip tests if not enough room.
1177  IF( lda.GT.nmax )
1178  $ GO TO 130
1179  laa = lda*na
1180 *
1181  DO 110 icu = 1, 2
1182  uplo = ichu( icu: icu )
1183 *
1184  DO 100 ict = 1, 3
1185  transa = icht( ict: ict )
1186 *
1187  DO 90 icd = 1, 2
1188  diag = ichd( icd: icd )
1189 *
1190  DO 80 ia = 1, nalf
1191  alpha = alf( ia )
1192 *
1193 * Generate the matrix A.
1194 *
1195  CALL zmake( 'tr', uplo, diag, na, na, a,
1196  $ nmax, aa, lda, reset, zero )
1197 *
1198 * Generate the matrix B.
1199 *
1200  CALL zmake( 'ge', ' ', ' ', m, n, b, nmax,
1201  $ bb, ldb, reset, zero )
1202 *
1203  nc = nc + 1
1204 *
1205 * Save every datum before calling the
1206 * subroutine.
1207 *
1208  sides = side
1209  uplos = uplo
1210  tranas = transa
1211  diags = diag
1212  ms = m
1213  ns = n
1214  als = alpha
1215  DO 30 i = 1, laa
1216  as( i ) = aa( i )
1217  30 CONTINUE
1218  ldas = lda
1219  DO 40 i = 1, lbb
1220  bs( i ) = bb( i )
1221  40 CONTINUE
1222  ldbs = ldb
1223 *
1224 * Call the subroutine.
1225 *
1226  IF( sname( 10: 11 ).EQ.'mm' )THEN
1227  IF( trace )
1228  $ CALL zprcn3( ntra, nc, sname, iorder,
1229  $ side, uplo, transa, diag, m, n, alpha,
1230  $ lda, ldb)
1231  IF( rewi )
1232  $ rewind ntra
1233  CALL cztrmm(iorder, side, uplo, transa,
1234  $ diag, m, n, alpha, aa, lda,
1235  $ bb, ldb )
1236  ELSE IF( sname( 10: 11 ).EQ.'sm' )THEN
1237  IF( trace )
1238  $ CALL zprcn3( ntra, nc, sname, iorder,
1239  $ side, uplo, transa, diag, m, n, alpha,
1240  $ lda, ldb)
1241  IF( rewi )
1242  $ rewind ntra
1243  CALL cztrsm(iorder, side, uplo, transa,
1244  $ diag, m, n, alpha, aa, lda,
1245  $ bb, ldb )
1246  END IF
1247 *
1248 * Check if error-exit was taken incorrectly.
1249 *
1250  IF( .NOT.ok )THEN
1251  WRITE( nout, fmt = 9994 )
1252  fatal = .true.
1253  GO TO 150
1254  END IF
1255 *
1256 * See what data changed inside subroutines.
1257 *
1258  isame( 1 ) = sides.EQ.side
1259  isame( 2 ) = uplos.EQ.uplo
1260  isame( 3 ) = tranas.EQ.transa
1261  isame( 4 ) = diags.EQ.diag
1262  isame( 5 ) = ms.EQ.m
1263  isame( 6 ) = ns.EQ.n
1264  isame( 7 ) = als.EQ.alpha
1265  isame( 8 ) = lze( as, aa, laa )
1266  isame( 9 ) = ldas.EQ.lda
1267  IF( null )THEN
1268  isame( 10 ) = lze( bs, bb, lbb )
1269  ELSE
1270  isame( 10 ) = lzeres( 'ge', ' ', m, n, bs,
1271  $ bb, ldb )
1272  END IF
1273  isame( 11 ) = ldbs.EQ.ldb
1274 *
1275 * If data was incorrectly changed, report and
1276 * return.
1277 *
1278  same = .true.
1279  DO 50 i = 1, nargs
1280  same = same.AND.isame( i )
1281  IF( .NOT.isame( i ) )
1282  $ WRITE( nout, fmt = 9998 )i
1283  50 CONTINUE
1284  IF( .NOT.same )THEN
1285  fatal = .true.
1286  GO TO 150
1287  END IF
1288 *
1289  IF( .NOT.null )THEN
1290  IF( sname( 10: 11 ).EQ.'mm' )THEN
1291 *
1292 * Check the result.
1293 *
1294  IF( left )THEN
1295  CALL zmmch( transa, 'N', m, n, m,
1296  $ alpha, a, nmax, b, nmax,
1297  $ zero, c, nmax, ct, g,
1298  $ bb, ldb, eps, err,
1299  $ fatal, nout, .true. )
1300  ELSE
1301  CALL zmmch( 'N', transa, m, n, n,
1302  $ alpha, b, nmax, a, nmax,
1303  $ zero, c, nmax, ct, g,
1304  $ bb, ldb, eps, err,
1305  $ fatal, nout, .true. )
1306  END IF
1307  ELSE IF( sname( 10: 11 ).EQ.'sm' )THEN
1308 *
1309 * Compute approximation to original
1310 * matrix.
1311 *
1312  DO 70 j = 1, n
1313  DO 60 i = 1, m
1314  c( i, j ) = bb( i + ( j - 1 )*
1315  $ ldb )
1316  bb( i + ( j - 1 )*ldb ) = alpha*
1317  $ b( i, j )
1318  60 CONTINUE
1319  70 CONTINUE
1320 *
1321  IF( left )THEN
1322  CALL zmmch( transa, 'N', m, n, m,
1323  $ one, a, nmax, c, nmax,
1324  $ zero, b, nmax, ct, g,
1325  $ bb, ldb, eps, err,
1326  $ fatal, nout, .false. )
1327  ELSE
1328  CALL zmmch( 'N', transa, m, n, n,
1329  $ one, c, nmax, a, nmax,
1330  $ zero, b, nmax, ct, g,
1331  $ bb, ldb, eps, err,
1332  $ fatal, nout, .false. )
1333  END IF
1334  END IF
1335  errmax = max( errmax, err )
1336 * If got really bad answer, report and
1337 * return.
1338  IF( fatal )
1339  $ GO TO 150
1340  END IF
1341 *
1342  80 CONTINUE
1343 *
1344  90 CONTINUE
1345 *
1346  100 CONTINUE
1347 *
1348  110 CONTINUE
1349 *
1350  120 CONTINUE
1351 *
1352  130 CONTINUE
1353 *
1354  140 CONTINUE
1355 *
1356 * Report result.
1357 *
1358  IF( errmax.LT.thresh )THEN
1359  IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
1360  IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
1361  ELSE
1362  IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
1363  IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
1364  END IF
1365  GO TO 160
1366 *
1367  150 CONTINUE
1368  WRITE( nout, fmt = 9996 )sname
1369  IF( trace )
1370  $ CALL zprcn3( ntra, nc, sname, iorder, side, uplo, transa, diag,
1371  $ m, n, alpha, lda, ldb)
1372 *
1373  160 CONTINUE
1374  RETURN
1375 *
1376 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1377  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1378  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1379 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1380  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1381  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1382 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1383  $ ' (', i6, ' CALL', 'S)' )
1384 10000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1385  $ ' (', i6, ' CALL', 'S)' )
1386  9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1387  $ 'ANGED INCORRECTLY *******' )
1388  9996 FORMAT(' ******* ', a12,' FAILED ON CALL NUMBER:' )
1389  9995 FORMAT(1x, i6, ': ', a12,'(', 4( '''', a1, ''',' ), 2( i3, ',' ),
1390  $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ') ',
1391  $ ' .' )
1392  9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1393  $ '******' )
1394 *
1395 * End of ZCHK3.
1396 *
1397  END
1398 *
1399  SUBROUTINE zprcn3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA,
1400  $ diag, m, n, alpha, lda, ldb)
1401  INTEGER NOUT, NC, IORDER, M, N, LDA, LDB
1402  DOUBLE COMPLEX ALPHA
1403  CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
1404  CHARACTER*12 SNAME
1405  CHARACTER*14 CRC, CS, CU, CA, CD
1406 
1407  IF (side.EQ.'L')THEN
1408  cs = ' CblasLeft'
1409  ELSE
1410  cs = ' CblasRight'
1411  END IF
1412  IF (uplo.EQ.'U')THEN
1413  cu = ' CblasUpper'
1414  ELSE
1415  cu = ' CblasLower'
1416  END IF
1417  IF (transa.EQ.'N')THEN
1418  ca = ' CblasNoTrans'
1419  ELSE IF (transa.EQ.'T')THEN
1420  ca = ' CblasTrans'
1421  ELSE
1422  ca = 'CblasConjTrans'
1423  END IF
1424  IF (diag.EQ.'N')THEN
1425  cd = ' CblasNonUnit'
1426  ELSE
1427  cd = ' CblasUnit'
1428  END IF
1429  IF (iorder.EQ.1)THEN
1430  crc = ' CblasRowMajor'
1431  ELSE
1432  crc = ' CblasColMajor'
1433  END IF
1434  WRITE(nout, fmt = 9995)nc,sname,crc, cs,cu
1435  WRITE(nout, fmt = 9994)ca, cd, m, n, alpha, lda, ldb
1436 
1437  9995 FORMAT( 1x, i6, ': ', a12,'(', a14, ',', a14, ',', a14, ',')
1438  9994 FORMAT( 10x, 2( a14, ',') , 2( i3, ',' ), ' (', f4.1, ',',
1439  $ f4.1, '), A,', i3, ', B,', i3, ').' )
1440  END
1441 *
1442  SUBROUTINE zchk4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1443  $ fatal, nidim, idim, nalf, alf, nbet, bet, nmax,
1444  $ a, aa, as, b, bb, bs, c, cc, cs, ct, g,
1445  $ iorder )
1446 *
1447 * Tests ZHERK and ZSYRK.
1448 *
1449 * Auxiliary routine for test program for Level 3 Blas.
1450 *
1451 * -- Written on 8-February-1989.
1452 * Jack Dongarra, Argonne National Laboratory.
1453 * Iain Duff, AERE Harwell.
1454 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1455 * Sven Hammarling, Numerical Algorithms Group Ltd.
1456 *
1457 * .. Parameters ..
1458  COMPLEX*16 ZERO
1459  parameter ( zero = ( 0.0d0, 0.0d0 ) )
1460  DOUBLE PRECISION RONE, RZERO
1461  parameter ( rone = 1.0d0, rzero = 0.0d0 )
1462 * .. Scalar Arguments ..
1463  DOUBLE PRECISION EPS, THRESH
1464  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1465  LOGICAL FATAL, REWI, TRACE
1466  CHARACTER*12 SNAME
1467 * .. Array Arguments ..
1468  COMPLEX*16 A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
1469  $ as( nmax*nmax ), b( nmax, nmax ),
1470  $ bb( nmax*nmax ), bet( nbet ), bs( nmax*nmax ),
1471  $ c( nmax, nmax ), cc( nmax*nmax ),
1472  $ cs( nmax*nmax ), ct( nmax )
1473  DOUBLE PRECISION G( nmax )
1474  INTEGER IDIM( nidim )
1475 * .. Local Scalars ..
1476  COMPLEX*16 ALPHA, ALS, BETA, BETS
1477  DOUBLE PRECISION ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS
1478  INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1479  $ laa, lcc, lda, ldas, ldc, ldcs, lj, ma, n, na,
1480  $ nargs, nc, ns
1481  LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER
1482  CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS
1483  CHARACTER*2 ICHT, ICHU
1484 * .. Local Arrays ..
1485  LOGICAL ISAME( 13 )
1486 * .. External Functions ..
1487  LOGICAL LZE, LZERES
1488  EXTERNAL lze, lzeres
1489 * .. External Subroutines ..
1490  EXTERNAL czherk, zmake, zmmch, czsyrk
1491 * .. Intrinsic Functions ..
1492  INTRINSIC dcmplx, max, dble
1493 * .. Scalars in Common ..
1494  INTEGER INFOT, NOUTC
1495  LOGICAL LERR, OK
1496 * .. Common blocks ..
1497  COMMON /infoc/infot, noutc, ok, lerr
1498 * .. Data statements ..
1499  DATA icht/'NC'/, ichu/'UL'/
1500 * .. Executable Statements ..
1501  conj = sname( 8: 9 ).EQ.'he'
1502 *
1503  nargs = 10
1504  nc = 0
1505  reset = .true.
1506  errmax = rzero
1507 *
1508  DO 100 in = 1, nidim
1509  n = idim( in )
1510 * Set LDC to 1 more than minimum value if room.
1511  ldc = n
1512  IF( ldc.LT.nmax )
1513  $ ldc = ldc + 1
1514 * Skip tests if not enough room.
1515  IF( ldc.GT.nmax )
1516  $ GO TO 100
1517  lcc = ldc*n
1518 *
1519  DO 90 ik = 1, nidim
1520  k = idim( ik )
1521 *
1522  DO 80 ict = 1, 2
1523  trans = icht( ict: ict )
1524  tran = trans.EQ.'C'
1525  IF( tran.AND..NOT.conj )
1526  $ trans = 'T'
1527  IF( tran )THEN
1528  ma = k
1529  na = n
1530  ELSE
1531  ma = n
1532  na = k
1533  END IF
1534 * Set LDA to 1 more than minimum value if room.
1535  lda = ma
1536  IF( lda.LT.nmax )
1537  $ lda = lda + 1
1538 * Skip tests if not enough room.
1539  IF( lda.GT.nmax )
1540  $ GO TO 80
1541  laa = lda*na
1542 *
1543 * Generate the matrix A.
1544 *
1545  CALL zmake( 'ge', ' ', ' ', ma, na, a, nmax, aa, lda,
1546  $ reset, zero )
1547 *
1548  DO 70 icu = 1, 2
1549  uplo = ichu( icu: icu )
1550  upper = uplo.EQ.'U'
1551 *
1552  DO 60 ia = 1, nalf
1553  alpha = alf( ia )
1554  IF( conj )THEN
1555  ralpha = dble( alpha )
1556  alpha = dcmplx( ralpha, rzero )
1557  END IF
1558 *
1559  DO 50 ib = 1, nbet
1560  beta = bet( ib )
1561  IF( conj )THEN
1562  rbeta = dble( beta )
1563  beta = dcmplx( rbeta, rzero )
1564  END IF
1565  null = n.LE.0
1566  IF( conj )
1567  $ null = null.OR.( ( k.LE.0.OR.ralpha.EQ.
1568  $ rzero ).AND.rbeta.EQ.rone )
1569 *
1570 * Generate the matrix C.
1571 *
1572  CALL zmake( sname( 8: 9 ), uplo, ' ', n, n, c,
1573  $ nmax, cc, ldc, reset, zero )
1574 *
1575  nc = nc + 1
1576 *
1577 * Save every datum before calling the subroutine.
1578 *
1579  uplos = uplo
1580  transs = trans
1581  ns = n
1582  ks = k
1583  IF( conj )THEN
1584  rals = ralpha
1585  ELSE
1586  als = alpha
1587  END IF
1588  DO 10 i = 1, laa
1589  as( i ) = aa( i )
1590  10 CONTINUE
1591  ldas = lda
1592  IF( conj )THEN
1593  rbets = rbeta
1594  ELSE
1595  bets = beta
1596  END IF
1597  DO 20 i = 1, lcc
1598  cs( i ) = cc( i )
1599  20 CONTINUE
1600  ldcs = ldc
1601 *
1602 * Call the subroutine.
1603 *
1604  IF( conj )THEN
1605  IF( trace )
1606  $ CALL zprcn6( ntra, nc, sname, iorder,
1607  $ uplo, trans, n, k, ralpha, lda, rbeta,
1608  $ ldc)
1609  IF( rewi )
1610  $ rewind ntra
1611  CALL czherk( iorder, uplo, trans, n, k,
1612  $ ralpha, aa, lda, rbeta, cc,
1613  $ ldc )
1614  ELSE
1615  IF( trace )
1616  $ CALL zprcn4( ntra, nc, sname, iorder,
1617  $ uplo, trans, n, k, alpha, lda, beta, ldc)
1618  IF( rewi )
1619  $ rewind ntra
1620  CALL czsyrk( iorder, uplo, trans, n, k,
1621  $ alpha, aa, lda, beta, cc, ldc )
1622  END IF
1623 *
1624 * Check if error-exit was taken incorrectly.
1625 *
1626  IF( .NOT.ok )THEN
1627  WRITE( nout, fmt = 9992 )
1628  fatal = .true.
1629  GO TO 120
1630  END IF
1631 *
1632 * See what data changed inside subroutines.
1633 *
1634  isame( 1 ) = uplos.EQ.uplo
1635  isame( 2 ) = transs.EQ.trans
1636  isame( 3 ) = ns.EQ.n
1637  isame( 4 ) = ks.EQ.k
1638  IF( conj )THEN
1639  isame( 5 ) = rals.EQ.ralpha
1640  ELSE
1641  isame( 5 ) = als.EQ.alpha
1642  END IF
1643  isame( 6 ) = lze( as, aa, laa )
1644  isame( 7 ) = ldas.EQ.lda
1645  IF( conj )THEN
1646  isame( 8 ) = rbets.EQ.rbeta
1647  ELSE
1648  isame( 8 ) = bets.EQ.beta
1649  END IF
1650  IF( null )THEN
1651  isame( 9 ) = lze( cs, cc, lcc )
1652  ELSE
1653  isame( 9 ) = lzeres( sname( 8: 9 ), uplo, n,
1654  $ n, cs, cc, ldc )
1655  END IF
1656  isame( 10 ) = ldcs.EQ.ldc
1657 *
1658 * If data was incorrectly changed, report and
1659 * return.
1660 *
1661  same = .true.
1662  DO 30 i = 1, nargs
1663  same = same.AND.isame( i )
1664  IF( .NOT.isame( i ) )
1665  $ WRITE( nout, fmt = 9998 )i
1666  30 CONTINUE
1667  IF( .NOT.same )THEN
1668  fatal = .true.
1669  GO TO 120
1670  END IF
1671 *
1672  IF( .NOT.null )THEN
1673 *
1674 * Check the result column by column.
1675 *
1676  IF( conj )THEN
1677  transt = 'C'
1678  ELSE
1679  transt = 'T'
1680  END IF
1681  jc = 1
1682  DO 40 j = 1, n
1683  IF( upper )THEN
1684  jj = 1
1685  lj = j
1686  ELSE
1687  jj = j
1688  lj = n - j + 1
1689  END IF
1690  IF( tran )THEN
1691  CALL zmmch( transt, 'N', lj, 1, k,
1692  $ alpha, a( 1, jj ), nmax,
1693  $ a( 1, j ), nmax, beta,
1694  $ c( jj, j ), nmax, ct, g,
1695  $ cc( jc ), ldc, eps, err,
1696  $ fatal, nout, .true. )
1697  ELSE
1698  CALL zmmch( 'N', transt, lj, 1, k,
1699  $ alpha, a( jj, 1 ), nmax,
1700  $ a( j, 1 ), nmax, beta,
1701  $ c( jj, j ), nmax, ct, g,
1702  $ cc( jc ), ldc, eps, err,
1703  $ fatal, nout, .true. )
1704  END IF
1705  IF( upper )THEN
1706  jc = jc + ldc
1707  ELSE
1708  jc = jc + ldc + 1
1709  END IF
1710  errmax = max( errmax, err )
1711 * If got really bad answer, report and
1712 * return.
1713  IF( fatal )
1714  $ GO TO 110
1715  40 CONTINUE
1716  END IF
1717 *
1718  50 CONTINUE
1719 *
1720  60 CONTINUE
1721 *
1722  70 CONTINUE
1723 *
1724  80 CONTINUE
1725 *
1726  90 CONTINUE
1727 *
1728  100 CONTINUE
1729 *
1730 * Report result.
1731 *
1732  IF( errmax.LT.thresh )THEN
1733  IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
1734  IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
1735  ELSE
1736  IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
1737  IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
1738  END IF
1739  GO TO 130
1740 *
1741  110 CONTINUE
1742  IF( n.GT.1 )
1743  $ WRITE( nout, fmt = 9995 )j
1744 *
1745  120 CONTINUE
1746  WRITE( nout, fmt = 9996 )sname
1747  IF( conj )THEN
1748  CALL zprcn6( nout, nc, sname, iorder, uplo, trans, n, k, ralpha,
1749  $ lda, rbeta, ldc)
1750  ELSE
1751  CALL zprcn4( nout, nc, sname, iorder, uplo, trans, n, k, alpha,
1752  $ lda, beta, ldc)
1753  END IF
1754 *
1755  130 CONTINUE
1756  RETURN
1757 *
1758 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1759  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1760  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1761 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1762  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1763  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1764 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1765  $ ' (', i6, ' CALL', 'S)' )
1766 10000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1767  $ ' (', i6, ' CALL', 'S)' )
1768  9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1769  $ 'ANGED INCORRECTLY *******' )
1770  9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
1771  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1772  9994 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1773  $ f4.1, ', A,', i3, ',', f4.1, ', C,', i3, ') ',
1774  $ ' .' )
1775  9993 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1776  $ '(', f4.1, ',', f4.1, ') , A,', i3, ',(', f4.1, ',', f4.1,
1777  $ '), C,', i3, ') .' )
1778  9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1779  $ '******' )
1780 *
1781 * End of CCHK4.
1782 *
1783  END
1784 *
1785  SUBROUTINE zprcn4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
1786  $ n, k, alpha, lda, beta, ldc)
1787  INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
1788  DOUBLE COMPLEX ALPHA, BETA
1789  CHARACTER*1 UPLO, TRANSA
1790  CHARACTER*12 SNAME
1791  CHARACTER*14 CRC, CU, CA
1792 
1793  IF (uplo.EQ.'U')THEN
1794  cu = ' CblasUpper'
1795  ELSE
1796  cu = ' CblasLower'
1797  END IF
1798  IF (transa.EQ.'N')THEN
1799  ca = ' CblasNoTrans'
1800  ELSE IF (transa.EQ.'T')THEN
1801  ca = ' CblasTrans'
1802  ELSE
1803  ca = 'CblasConjTrans'
1804  END IF
1805  IF (iorder.EQ.1)THEN
1806  crc = ' CblasRowMajor'
1807  ELSE
1808  crc = ' CblasColMajor'
1809  END IF
1810  WRITE(nout, fmt = 9995)nc, sname, crc, cu, ca
1811  WRITE(nout, fmt = 9994)n, k, alpha, lda, beta, ldc
1812 
1813  9995 FORMAT( 1x, i6, ': ', a12,'(', 3( a14, ',') )
1814  9994 FORMAT( 10x, 2( i3, ',' ), ' (', f4.1, ',', f4.1 ,'), A,',
1815  $ i3, ', (', f4.1,',', f4.1, '), C,', i3, ').' )
1816  END
1817 *
1818 *
1819  SUBROUTINE zprcn6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
1820  $ n, k, alpha, lda, beta, ldc)
1821  INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
1822  DOUBLE PRECISION ALPHA, BETA
1823  CHARACTER*1 UPLO, TRANSA
1824  CHARACTER*12 SNAME
1825  CHARACTER*14 CRC, CU, CA
1826 
1827  IF (uplo.EQ.'U')THEN
1828  cu = ' CblasUpper'
1829  ELSE
1830  cu = ' CblasLower'
1831  END IF
1832  IF (transa.EQ.'N')THEN
1833  ca = ' CblasNoTrans'
1834  ELSE IF (transa.EQ.'T')THEN
1835  ca = ' CblasTrans'
1836  ELSE
1837  ca = 'CblasConjTrans'
1838  END IF
1839  IF (iorder.EQ.1)THEN
1840  crc = ' CblasRowMajor'
1841  ELSE
1842  crc = ' CblasColMajor'
1843  END IF
1844  WRITE(nout, fmt = 9995)nc, sname, crc, cu, ca
1845  WRITE(nout, fmt = 9994)n, k, alpha, lda, beta, ldc
1846 
1847  9995 FORMAT( 1x, i6, ': ', a12,'(', 3( a14, ',') )
1848  9994 FORMAT( 10x, 2( i3, ',' ),
1849  $ f4.1, ', A,', i3, ',', f4.1, ', C,', i3, ').' )
1850  END
1851 *
1852  SUBROUTINE zchk5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1853  $ fatal, nidim, idim, nalf, alf, nbet, bet, nmax,
1854  $ ab, aa, as, bb, bs, c, cc, cs, ct, g, w,
1855  $ iorder )
1856 *
1857 * Tests ZHER2K and ZSYR2K.
1858 *
1859 * Auxiliary routine for test program for Level 3 Blas.
1860 *
1861 * -- Written on 8-February-1989.
1862 * Jack Dongarra, Argonne National Laboratory.
1863 * Iain Duff, AERE Harwell.
1864 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1865 * Sven Hammarling, Numerical Algorithms Group Ltd.
1866 *
1867 * .. Parameters ..
1868  COMPLEX*16 ZERO, ONE
1869  parameter ( zero = ( 0.0d0, 0.0d0 ), one = ( 1.0d0, 0.0d0 ) )
1870  DOUBLE PRECISION RONE, RZERO
1871  parameter ( rone = 1.0d0, rzero = 0.0d0 )
1872 * .. Scalar Arguments ..
1873  DOUBLE PRECISION EPS, THRESH
1874  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1875  LOGICAL FATAL, REWI, TRACE
1876  CHARACTER*12 SNAME
1877 * .. Array Arguments ..
1878  COMPLEX*16 AA( nmax*nmax ), AB( 2*nmax*nmax ),
1879  $ alf( nalf ), as( nmax*nmax ), bb( nmax*nmax ),
1880  $ bet( nbet ), bs( nmax*nmax ), c( nmax, nmax ),
1881  $ cc( nmax*nmax ), cs( nmax*nmax ), ct( nmax ),
1882  $ w( 2*nmax )
1883  DOUBLE PRECISION G( nmax )
1884  INTEGER IDIM( nidim )
1885 * .. Local Scalars ..
1886  COMPLEX*16 ALPHA, ALS, BETA, BETS
1887  DOUBLE PRECISION ERR, ERRMAX, RBETA, RBETS
1888  INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1889  $ k, ks, laa, lbb, lcc, lda, ldas, ldb, ldbs,
1890  $ ldc, ldcs, lj, ma, n, na, nargs, nc, ns
1891  LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER
1892  CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS
1893  CHARACTER*2 ICHT, ICHU
1894 * .. Local Arrays ..
1895  LOGICAL ISAME( 13 )
1896 * .. External Functions ..
1897  LOGICAL LZE, LZERES
1898  EXTERNAL lze, lzeres
1899 * .. External Subroutines ..
1900  EXTERNAL czher2k, zmake, zmmch, czsyr2k
1901 * .. Intrinsic Functions ..
1902  INTRINSIC dcmplx, dconjg, max, dble
1903 * .. Scalars in Common ..
1904  INTEGER INFOT, NOUTC
1905  LOGICAL LERR, OK
1906 * .. Common blocks ..
1907  COMMON /infoc/infot, noutc, ok, lerr
1908 * .. Data statements ..
1909  DATA icht/'NC'/, ichu/'UL'/
1910 * .. Executable Statements ..
1911  conj = sname( 8: 9 ).EQ.'he'
1912 *
1913  nargs = 12
1914  nc = 0
1915  reset = .true.
1916  errmax = rzero
1917 *
1918  DO 130 in = 1, nidim
1919  n = idim( in )
1920 * Set LDC to 1 more than minimum value if room.
1921  ldc = n
1922  IF( ldc.LT.nmax )
1923  $ ldc = ldc + 1
1924 * Skip tests if not enough room.
1925  IF( ldc.GT.nmax )
1926  $ GO TO 130
1927  lcc = ldc*n
1928 *
1929  DO 120 ik = 1, nidim
1930  k = idim( ik )
1931 *
1932  DO 110 ict = 1, 2
1933  trans = icht( ict: ict )
1934  tran = trans.EQ.'C'
1935  IF( tran.AND..NOT.conj )
1936  $ trans = 'T'
1937  IF( tran )THEN
1938  ma = k
1939  na = n
1940  ELSE
1941  ma = n
1942  na = k
1943  END IF
1944 * Set LDA to 1 more than minimum value if room.
1945  lda = ma
1946  IF( lda.LT.nmax )
1947  $ lda = lda + 1
1948 * Skip tests if not enough room.
1949  IF( lda.GT.nmax )
1950  $ GO TO 110
1951  laa = lda*na
1952 *
1953 * Generate the matrix A.
1954 *
1955  IF( tran )THEN
1956  CALL zmake( 'ge', ' ', ' ', ma, na, ab, 2*nmax, aa,
1957  $ lda, reset, zero )
1958  ELSE
1959  CALL zmake( 'ge', ' ', ' ', ma, na, ab, nmax, aa, lda,
1960  $ reset, zero )
1961  END IF
1962 *
1963 * Generate the matrix B.
1964 *
1965  ldb = lda
1966  lbb = laa
1967  IF( tran )THEN
1968  CALL zmake( 'ge', ' ', ' ', ma, na, ab( k + 1 ),
1969  $ 2*nmax, bb, ldb, reset, zero )
1970  ELSE
1971  CALL zmake( 'ge', ' ', ' ', ma, na, ab( k*nmax + 1 ),
1972  $ nmax, bb, ldb, reset, zero )
1973  END IF
1974 *
1975  DO 100 icu = 1, 2
1976  uplo = ichu( icu: icu )
1977  upper = uplo.EQ.'U'
1978 *
1979  DO 90 ia = 1, nalf
1980  alpha = alf( ia )
1981 *
1982  DO 80 ib = 1, nbet
1983  beta = bet( ib )
1984  IF( conj )THEN
1985  rbeta = dble( beta )
1986  beta = dcmplx( rbeta, rzero )
1987  END IF
1988  null = n.LE.0
1989  IF( conj )
1990  $ null = null.OR.( ( k.LE.0.OR.alpha.EQ.
1991  $ zero ).AND.rbeta.EQ.rone )
1992 *
1993 * Generate the matrix C.
1994 *
1995  CALL zmake( sname( 8: 9 ), uplo, ' ', n, n, c,
1996  $ nmax, cc, ldc, reset, zero )
1997 *
1998  nc = nc + 1
1999 *
2000 * Save every datum before calling the subroutine.
2001 *
2002  uplos = uplo
2003  transs = trans
2004  ns = n
2005  ks = k
2006  als = alpha
2007  DO 10 i = 1, laa
2008  as( i ) = aa( i )
2009  10 CONTINUE
2010  ldas = lda
2011  DO 20 i = 1, lbb
2012  bs( i ) = bb( i )
2013  20 CONTINUE
2014  ldbs = ldb
2015  IF( conj )THEN
2016  rbets = rbeta
2017  ELSE
2018  bets = beta
2019  END IF
2020  DO 30 i = 1, lcc
2021  cs( i ) = cc( i )
2022  30 CONTINUE
2023  ldcs = ldc
2024 *
2025 * Call the subroutine.
2026 *
2027  IF( conj )THEN
2028  IF( trace )
2029  $ CALL zprcn7( ntra, nc, sname, iorder,
2030  $ uplo, trans, n, k, alpha, lda, ldb,
2031  $ rbeta, ldc)
2032  IF( rewi )
2033  $ rewind ntra
2034  CALL czher2k( iorder, uplo, trans, n, k,
2035  $ alpha, aa, lda, bb, ldb, rbeta,
2036  $ cc, ldc )
2037  ELSE
2038  IF( trace )
2039  $ CALL zprcn5( ntra, nc, sname, iorder,
2040  $ uplo, trans, n, k, alpha, lda, ldb,
2041  $ beta, ldc)
2042  IF( rewi )
2043  $ rewind ntra
2044  CALL czsyr2k( iorder, uplo, trans, n, k,
2045  $ alpha, aa, lda, bb, ldb, beta,
2046  $ cc, ldc )
2047  END IF
2048 *
2049 * Check if error-exit was taken incorrectly.
2050 *
2051  IF( .NOT.ok )THEN
2052  WRITE( nout, fmt = 9992 )
2053  fatal = .true.
2054  GO TO 150
2055  END IF
2056 *
2057 * See what data changed inside subroutines.
2058 *
2059  isame( 1 ) = uplos.EQ.uplo
2060  isame( 2 ) = transs.EQ.trans
2061  isame( 3 ) = ns.EQ.n
2062  isame( 4 ) = ks.EQ.k
2063  isame( 5 ) = als.EQ.alpha
2064  isame( 6 ) = lze( as, aa, laa )
2065  isame( 7 ) = ldas.EQ.lda
2066  isame( 8 ) = lze( bs, bb, lbb )
2067  isame( 9 ) = ldbs.EQ.ldb
2068  IF( conj )THEN
2069  isame( 10 ) = rbets.EQ.rbeta
2070  ELSE
2071  isame( 10 ) = bets.EQ.beta
2072  END IF
2073  IF( null )THEN
2074  isame( 11 ) = lze( cs, cc, lcc )
2075  ELSE
2076  isame( 11 ) = lzeres( 'he', uplo, n, n, cs,
2077  $ cc, ldc )
2078  END IF
2079  isame( 12 ) = ldcs.EQ.ldc
2080 *
2081 * If data was incorrectly changed, report and
2082 * return.
2083 *
2084  same = .true.
2085  DO 40 i = 1, nargs
2086  same = same.AND.isame( i )
2087  IF( .NOT.isame( i ) )
2088  $ WRITE( nout, fmt = 9998 )i
2089  40 CONTINUE
2090  IF( .NOT.same )THEN
2091  fatal = .true.
2092  GO TO 150
2093  END IF
2094 *
2095  IF( .NOT.null )THEN
2096 *
2097 * Check the result column by column.
2098 *
2099  IF( conj )THEN
2100  transt = 'C'
2101  ELSE
2102  transt = 'T'
2103  END IF
2104  jjab = 1
2105  jc = 1
2106  DO 70 j = 1, n
2107  IF( upper )THEN
2108  jj = 1
2109  lj = j
2110  ELSE
2111  jj = j
2112  lj = n - j + 1
2113  END IF
2114  IF( tran )THEN
2115  DO 50 i = 1, k
2116  w( i ) = alpha*ab( ( j - 1 )*2*
2117  $ nmax + k + i )
2118  IF( conj )THEN
2119  w( k + i ) = dconjg( alpha )*
2120  $ ab( ( j - 1 )*2*
2121  $ nmax + i )
2122  ELSE
2123  w( k + i ) = alpha*
2124  $ ab( ( j - 1 )*2*
2125  $ nmax + i )
2126  END IF
2127  50 CONTINUE
2128  CALL zmmch( transt, 'N', lj, 1, 2*k,
2129  $ one, ab( jjab ), 2*nmax, w,
2130  $ 2*nmax, beta, c( jj, j ),
2131  $ nmax, ct, g, cc( jc ), ldc,
2132  $ eps, err, fatal, nout,
2133  $ .true. )
2134  ELSE
2135  DO 60 i = 1, k
2136  IF( conj )THEN
2137  w( i ) = alpha*dconjg( ab( ( k +
2138  $ i - 1 )*nmax + j ) )
2139  w( k + i ) = dconjg( alpha*
2140  $ ab( ( i - 1 )*nmax +
2141  $ j ) )
2142  ELSE
2143  w( i ) = alpha*ab( ( k + i - 1 )*
2144  $ nmax + j )
2145  w( k + i ) = alpha*
2146  $ ab( ( i - 1 )*nmax +
2147  $ j )
2148  END IF
2149  60 CONTINUE
2150  CALL zmmch( 'N', 'N', lj, 1, 2*k, one,
2151  $ ab( jj ), nmax, w, 2*nmax,
2152  $ beta, c( jj, j ), nmax, ct,
2153  $ g, cc( jc ), ldc, eps, err,
2154  $ fatal, nout, .true. )
2155  END IF
2156  IF( upper )THEN
2157  jc = jc + ldc
2158  ELSE
2159  jc = jc + ldc + 1
2160  IF( tran )
2161  $ jjab = jjab + 2*nmax
2162  END IF
2163  errmax = max( errmax, err )
2164 * If got really bad answer, report and
2165 * return.
2166  IF( fatal )
2167  $ GO TO 140
2168  70 CONTINUE
2169  END IF
2170 *
2171  80 CONTINUE
2172 *
2173  90 CONTINUE
2174 *
2175  100 CONTINUE
2176 *
2177  110 CONTINUE
2178 *
2179  120 CONTINUE
2180 *
2181  130 CONTINUE
2182 *
2183 * Report result.
2184 *
2185  IF( errmax.LT.thresh )THEN
2186  IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
2187  IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
2188  ELSE
2189  IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
2190  IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
2191  END IF
2192  GO TO 160
2193 *
2194  140 CONTINUE
2195  IF( n.GT.1 )
2196  $ WRITE( nout, fmt = 9995 )j
2197 *
2198  150 CONTINUE
2199  WRITE( nout, fmt = 9996 )sname
2200  IF( conj )THEN
2201  CALL zprcn7( nout, nc, sname, iorder, uplo, trans, n, k,
2202  $ alpha, lda, ldb, rbeta, ldc)
2203  ELSE
2204  CALL zprcn5( nout, nc, sname, iorder, uplo, trans, n, k,
2205  $ alpha, lda, ldb, beta, ldc)
2206  END IF
2207 *
2208  160 CONTINUE
2209  RETURN
2210 *
2211 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2212  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2213  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
2214 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2215  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2216  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
2217 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2218  $ ' (', i6, ' CALL', 'S)' )
2219 10000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2220  $ ' (', i6, ' CALL', 'S)' )
2221  9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2222  $ 'ANGED INCORRECTLY *******' )
2223  9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
2224  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2225  9994 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
2226  $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',', f4.1,
2227  $ ', C,', i3, ') .' )
2228  9993 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
2229  $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',(', f4.1,
2230  $ ',', f4.1, '), C,', i3, ') .' )
2231  9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2232  $ '******' )
2233 *
2234 * End of ZCHK5.
2235 *
2236  END
2237 *
2238  SUBROUTINE zprcn5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
2239  $ n, k, alpha, lda, ldb, beta, ldc)
2240  INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
2241  DOUBLE COMPLEX ALPHA, BETA
2242  CHARACTER*1 UPLO, TRANSA
2243  CHARACTER*12 SNAME
2244  CHARACTER*14 CRC, CU, CA
2245 
2246  IF (uplo.EQ.'U')THEN
2247  cu = ' CblasUpper'
2248  ELSE
2249  cu = ' CblasLower'
2250  END IF
2251  IF (transa.EQ.'N')THEN
2252  ca = ' CblasNoTrans'
2253  ELSE IF (transa.EQ.'T')THEN
2254  ca = ' CblasTrans'
2255  ELSE
2256  ca = 'CblasConjTrans'
2257  END IF
2258  IF (iorder.EQ.1)THEN
2259  crc = ' CblasRowMajor'
2260  ELSE
2261  crc = ' CblasColMajor'
2262  END IF
2263  WRITE(nout, fmt = 9995)nc, sname, crc, cu, ca
2264  WRITE(nout, fmt = 9994)n, k, alpha, lda, ldb, beta, ldc
2265 
2266  9995 FORMAT( 1x, i6, ': ', a12,'(', 3( a14, ',') )
2267  9994 FORMAT( 10x, 2( i3, ',' ), ' (', f4.1, ',', f4.1, '), A,',
2268  $ i3, ', B', i3, ', (', f4.1, ',', f4.1, '), C,', i3, ').' )
2269  END
2270 *
2271 *
2272  SUBROUTINE zprcn7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
2273  $ n, k, alpha, lda, ldb, beta, ldc)
2274  INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
2275  DOUBLE COMPLEX ALPHA
2276  DOUBLE PRECISION BETA
2277  CHARACTER*1 UPLO, TRANSA
2278  CHARACTER*12 SNAME
2279  CHARACTER*14 CRC, CU, CA
2280 
2281  IF (uplo.EQ.'U')THEN
2282  cu = ' CblasUpper'
2283  ELSE
2284  cu = ' CblasLower'
2285  END IF
2286  IF (transa.EQ.'N')THEN
2287  ca = ' CblasNoTrans'
2288  ELSE IF (transa.EQ.'T')THEN
2289  ca = ' CblasTrans'
2290  ELSE
2291  ca = 'CblasConjTrans'
2292  END IF
2293  IF (iorder.EQ.1)THEN
2294  crc = ' CblasRowMajor'
2295  ELSE
2296  crc = ' CblasColMajor'
2297  END IF
2298  WRITE(nout, fmt = 9995)nc, sname, crc, cu, ca
2299  WRITE(nout, fmt = 9994)n, k, alpha, lda, ldb, beta, ldc
2300 
2301  9995 FORMAT( 1x, i6, ': ', a12,'(', 3( a14, ',') )
2302  9994 FORMAT( 10x, 2( i3, ',' ), ' (', f4.1, ',', f4.1, '), A,',
2303  $ i3, ', B', i3, ',', f4.1, ', C,', i3, ').' )
2304  END
2305 *
2306  SUBROUTINE zmake( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
2307  $ transl )
2308 *
2309 * Generates values for an M by N matrix A.
2310 * Stores the values in the array AA in the data structure required
2311 * by the routine, with unwanted elements set to rogue value.
2312 *
2313 * TYPE is 'ge', 'he', 'sy' or 'tr'.
2314 *
2315 * Auxiliary routine for test program for Level 3 Blas.
2316 *
2317 * -- Written on 8-February-1989.
2318 * Jack Dongarra, Argonne National Laboratory.
2319 * Iain Duff, AERE Harwell.
2320 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2321 * Sven Hammarling, Numerical Algorithms Group Ltd.
2322 *
2323 * .. Parameters ..
2324  COMPLEX*16 ZERO, ONE
2325  parameter ( zero = ( 0.0d0, 0.0d0 ),
2326  $ one = ( 1.0d0, 0.0d0 ) )
2327  COMPLEX*16 ROGUE
2328  parameter ( rogue = ( -1.0d10, 1.0d10 ) )
2329  DOUBLE PRECISION RZERO
2330  parameter ( rzero = 0.0d0 )
2331  DOUBLE PRECISION RROGUE
2332  parameter ( rrogue = -1.0d10 )
2333 * .. Scalar Arguments ..
2334  COMPLEX*16 TRANSL
2335  INTEGER LDA, M, N, NMAX
2336  LOGICAL RESET
2337  CHARACTER*1 DIAG, UPLO
2338  CHARACTER*2 TYPE
2339 * .. Array Arguments ..
2340  COMPLEX*16 A( nmax, * ), AA( * )
2341 * .. Local Scalars ..
2342  INTEGER I, IBEG, IEND, J, JJ
2343  LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER
2344 * .. External Functions ..
2345  COMPLEX*16 ZBEG
2346  EXTERNAL zbeg
2347 * .. Intrinsic Functions ..
2348  INTRINSIC dcmplx, dconjg, dble
2349 * .. Executable Statements ..
2350  gen = type.EQ.'ge'
2351  her = type.EQ.'he'
2352  sym = type.EQ.'sy'
2353  tri = type.EQ.'tr'
2354  upper = ( her.OR.sym.OR.tri ).AND.uplo.EQ.'U'
2355  lower = ( her.OR.sym.OR.tri ).AND.uplo.EQ.'L'
2356  unit = tri.AND.diag.EQ.'U'
2357 *
2358 * Generate data in array A.
2359 *
2360  DO 20 j = 1, n
2361  DO 10 i = 1, m
2362  IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
2363  $ THEN
2364  a( i, j ) = zbeg( reset ) + transl
2365  IF( i.NE.j )THEN
2366 * Set some elements to zero
2367  IF( n.GT.3.AND.j.EQ.n/2 )
2368  $ a( i, j ) = zero
2369  IF( her )THEN
2370  a( j, i ) = dconjg( a( i, j ) )
2371  ELSE IF( sym )THEN
2372  a( j, i ) = a( i, j )
2373  ELSE IF( tri )THEN
2374  a( j, i ) = zero
2375  END IF
2376  END IF
2377  END IF
2378  10 CONTINUE
2379  IF( her )
2380  $ a( j, j ) = dcmplx( dble( a( j, j ) ), rzero )
2381  IF( tri )
2382  $ a( j, j ) = a( j, j ) + one
2383  IF( unit )
2384  $ a( j, j ) = one
2385  20 CONTINUE
2386 *
2387 * Store elements in array AS in data structure required by routine.
2388 *
2389  IF( type.EQ.'ge' )THEN
2390  DO 50 j = 1, n
2391  DO 30 i = 1, m
2392  aa( i + ( j - 1 )*lda ) = a( i, j )
2393  30 CONTINUE
2394  DO 40 i = m + 1, lda
2395  aa( i + ( j - 1 )*lda ) = rogue
2396  40 CONTINUE
2397  50 CONTINUE
2398  ELSE IF( type.EQ.'he'.OR.type.EQ.'sy'.OR.type.EQ.'tr' )THEN
2399  DO 90 j = 1, n
2400  IF( upper )THEN
2401  ibeg = 1
2402  IF( unit )THEN
2403  iend = j - 1
2404  ELSE
2405  iend = j
2406  END IF
2407  ELSE
2408  IF( unit )THEN
2409  ibeg = j + 1
2410  ELSE
2411  ibeg = j
2412  END IF
2413  iend = n
2414  END IF
2415  DO 60 i = 1, ibeg - 1
2416  aa( i + ( j - 1 )*lda ) = rogue
2417  60 CONTINUE
2418  DO 70 i = ibeg, iend
2419  aa( i + ( j - 1 )*lda ) = a( i, j )
2420  70 CONTINUE
2421  DO 80 i = iend + 1, lda
2422  aa( i + ( j - 1 )*lda ) = rogue
2423  80 CONTINUE
2424  IF( her )THEN
2425  jj = j + ( j - 1 )*lda
2426  aa( jj ) = dcmplx( dble( aa( jj ) ), rrogue )
2427  END IF
2428  90 CONTINUE
2429  END IF
2430  RETURN
2431 *
2432 * End of ZMAKE.
2433 *
2434  END
2435  SUBROUTINE zmmch( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
2436  $ beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal,
2437  $ nout, mv )
2438 *
2439 * Checks the results of the computational tests.
2440 *
2441 * Auxiliary routine for test program for Level 3 Blas.
2442 *
2443 * -- Written on 8-February-1989.
2444 * Jack Dongarra, Argonne National Laboratory.
2445 * Iain Duff, AERE Harwell.
2446 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2447 * Sven Hammarling, Numerical Algorithms Group Ltd.
2448 *
2449 * .. Parameters ..
2450  COMPLEX*16 ZERO
2451  parameter ( zero = ( 0.0d0, 0.0d0 ) )
2452  DOUBLE PRECISION RZERO, RONE
2453  parameter ( rzero = 0.0d0, rone = 1.0d0 )
2454 * .. Scalar Arguments ..
2455  COMPLEX*16 ALPHA, BETA
2456  DOUBLE PRECISION EPS, ERR
2457  INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
2458  LOGICAL FATAL, MV
2459  CHARACTER*1 TRANSA, TRANSB
2460 * .. Array Arguments ..
2461  COMPLEX*16 A( lda, * ), B( ldb, * ), C( ldc, * ),
2462  $ cc( ldcc, * ), ct( * )
2463  DOUBLE PRECISION G( * )
2464 * .. Local Scalars ..
2465  COMPLEX*16 CL
2466  DOUBLE PRECISION ERRI
2467  INTEGER I, J, K
2468  LOGICAL CTRANA, CTRANB, TRANA, TRANB
2469 * .. Intrinsic Functions ..
2470  INTRINSIC abs, dimag, dconjg, max, dble, sqrt
2471 * .. Statement Functions ..
2472  DOUBLE PRECISION ABS1
2473 * .. Statement Function definitions ..
2474  abs1( cl ) = abs( dble( cl ) ) + abs( dimag( cl ) )
2475 * .. Executable Statements ..
2476  trana = transa.EQ.'T'.OR.transa.EQ.'C'
2477  tranb = transb.EQ.'T'.OR.transb.EQ.'C'
2478  ctrana = transa.EQ.'C'
2479  ctranb = transb.EQ.'C'
2480 *
2481 * Compute expected result, one column at a time, in CT using data
2482 * in A, B and C.
2483 * Compute gauges in G.
2484 *
2485  DO 220 j = 1, n
2486 *
2487  DO 10 i = 1, m
2488  ct( i ) = zero
2489  g( i ) = rzero
2490  10 CONTINUE
2491  IF( .NOT.trana.AND..NOT.tranb )THEN
2492  DO 30 k = 1, kk
2493  DO 20 i = 1, m
2494  ct( i ) = ct( i ) + a( i, k )*b( k, j )
2495  g( i ) = g( i ) + abs1( a( i, k ) )*abs1( b( k, j ) )
2496  20 CONTINUE
2497  30 CONTINUE
2498  ELSE IF( trana.AND..NOT.tranb )THEN
2499  IF( ctrana )THEN
2500  DO 50 k = 1, kk
2501  DO 40 i = 1, m
2502  ct( i ) = ct( i ) + dconjg( a( k, i ) )*b( k, j )
2503  g( i ) = g( i ) + abs1( a( k, i ) )*
2504  $ abs1( b( k, j ) )
2505  40 CONTINUE
2506  50 CONTINUE
2507  ELSE
2508  DO 70 k = 1, kk
2509  DO 60 i = 1, m
2510  ct( i ) = ct( i ) + a( k, i )*b( k, j )
2511  g( i ) = g( i ) + abs1( a( k, i ) )*
2512  $ abs1( b( k, j ) )
2513  60 CONTINUE
2514  70 CONTINUE
2515  END IF
2516  ELSE IF( .NOT.trana.AND.tranb )THEN
2517  IF( ctranb )THEN
2518  DO 90 k = 1, kk
2519  DO 80 i = 1, m
2520  ct( i ) = ct( i ) + a( i, k )*dconjg( b( j, k ) )
2521  g( i ) = g( i ) + abs1( a( i, k ) )*
2522  $ abs1( b( j, k ) )
2523  80 CONTINUE
2524  90 CONTINUE
2525  ELSE
2526  DO 110 k = 1, kk
2527  DO 100 i = 1, m
2528  ct( i ) = ct( i ) + a( i, k )*b( j, k )
2529  g( i ) = g( i ) + abs1( a( i, k ) )*
2530  $ abs1( b( j, k ) )
2531  100 CONTINUE
2532  110 CONTINUE
2533  END IF
2534  ELSE IF( trana.AND.tranb )THEN
2535  IF( ctrana )THEN
2536  IF( ctranb )THEN
2537  DO 130 k = 1, kk
2538  DO 120 i = 1, m
2539  ct( i ) = ct( i ) + dconjg( a( k, i ) )*
2540  $ dconjg( b( j, k ) )
2541  g( i ) = g( i ) + abs1( a( k, i ) )*
2542  $ abs1( b( j, k ) )
2543  120 CONTINUE
2544  130 CONTINUE
2545  ELSE
2546  DO 150 k = 1, kk
2547  DO 140 i = 1, m
2548  ct( i ) = ct( i ) + dconjg( a( k, i ) )*
2549  $ b( j, k )
2550  g( i ) = g( i ) + abs1( a( k, i ) )*
2551  $ abs1( b( j, k ) )
2552  140 CONTINUE
2553  150 CONTINUE
2554  END IF
2555  ELSE
2556  IF( ctranb )THEN
2557  DO 170 k = 1, kk
2558  DO 160 i = 1, m
2559  ct( i ) = ct( i ) + a( k, i )*
2560  $ dconjg( b( j, k ) )
2561  g( i ) = g( i ) + abs1( a( k, i ) )*
2562  $ abs1( b( j, k ) )
2563  160 CONTINUE
2564  170 CONTINUE
2565  ELSE
2566  DO 190 k = 1, kk
2567  DO 180 i = 1, m
2568  ct( i ) = ct( i ) + a( k, i )*b( j, k )
2569  g( i ) = g( i ) + abs1( a( k, i ) )*
2570  $ abs1( b( j, k ) )
2571  180 CONTINUE
2572  190 CONTINUE
2573  END IF
2574  END IF
2575  END IF
2576  DO 200 i = 1, m
2577  ct( i ) = alpha*ct( i ) + beta*c( i, j )
2578  g( i ) = abs1( alpha )*g( i ) +
2579  $ abs1( beta )*abs1( c( i, j ) )
2580  200 CONTINUE
2581 *
2582 * Compute the error ratio for this result.
2583 *
2584  err = zero
2585  DO 210 i = 1, m
2586  erri = abs1( ct( i ) - cc( i, j ) )/eps
2587  IF( g( i ).NE.rzero )
2588  $ erri = erri/g( i )
2589  err = max( err, erri )
2590  IF( err*sqrt( eps ).GE.rone )
2591  $ GO TO 230
2592  210 CONTINUE
2593 *
2594  220 CONTINUE
2595 *
2596 * If the loop completes, all results are at least half accurate.
2597  GO TO 250
2598 *
2599 * Report fatal error.
2600 *
2601  230 fatal = .true.
2602  WRITE( nout, fmt = 9999 )
2603  DO 240 i = 1, m
2604  IF( mv )THEN
2605  WRITE( nout, fmt = 9998 )i, ct( i ), cc( i, j )
2606  ELSE
2607  WRITE( nout, fmt = 9998 )i, cc( i, j ), ct( i )
2608  END IF
2609  240 CONTINUE
2610  IF( n.GT.1 )
2611  $ WRITE( nout, fmt = 9997 )j
2612 *
2613  250 CONTINUE
2614  RETURN
2615 *
2616  9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2617  $ 'F ACCURATE *******', /' EXPECTED RE',
2618  $ 'SULT COMPUTED RESULT' )
2619  9998 FORMAT( 1x, i7, 2( ' (', g15.6, ',', g15.6, ')' ) )
2620  9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2621 *
2622 * End of ZMMCH.
2623 *
2624  END
2625  LOGICAL FUNCTION lze( RI, RJ, LR )
2626 *
2627 * Tests if two arrays are identical.
2628 *
2629 * Auxiliary routine for test program for Level 3 Blas.
2630 *
2631 * -- Written on 8-February-1989.
2632 * Jack Dongarra, Argonne National Laboratory.
2633 * Iain Duff, AERE Harwell.
2634 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2635 * Sven Hammarling, Numerical Algorithms Group Ltd.
2636 *
2637 * .. Scalar Arguments ..
2638  INTEGER LR
2639 * .. Array Arguments ..
2640  COMPLEX*16 RI( * ), RJ( * )
2641 * .. Local Scalars ..
2642  INTEGER I
2643 * .. Executable Statements ..
2644  DO 10 i = 1, lr
2645  IF( ri( i ).NE.rj( i ) )
2646  $ GO TO 20
2647  10 CONTINUE
2648  lze = .true.
2649  GO TO 30
2650  20 CONTINUE
2651  lze = .false.
2652  30 RETURN
2653 *
2654 * End of LZE.
2655 *
2656  END
2657  LOGICAL FUNCTION lzeres( TYPE, UPLO, M, N, AA, AS, LDA )
2658 *
2659 * Tests if selected elements in two arrays are equal.
2660 *
2661 * TYPE is 'ge' or 'he' or 'sy'.
2662 *
2663 * Auxiliary routine for test program for Level 3 Blas.
2664 *
2665 * -- Written on 8-February-1989.
2666 * Jack Dongarra, Argonne National Laboratory.
2667 * Iain Duff, AERE Harwell.
2668 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2669 * Sven Hammarling, Numerical Algorithms Group Ltd.
2670 *
2671 * .. Scalar Arguments ..
2672  INTEGER LDA, M, N
2673  CHARACTER*1 UPLO
2674  CHARACTER*2 TYPE
2675 * .. Array Arguments ..
2676  COMPLEX*16 AA( lda, * ), AS( lda, * )
2677 * .. Local Scalars ..
2678  INTEGER I, IBEG, IEND, J
2679  LOGICAL UPPER
2680 * .. Executable Statements ..
2681  upper = uplo.EQ.'U'
2682  IF( type.EQ.'ge' )THEN
2683  DO 20 j = 1, n
2684  DO 10 i = m + 1, lda
2685  IF( aa( i, j ).NE.as( i, j ) )
2686  $ GO TO 70
2687  10 CONTINUE
2688  20 CONTINUE
2689  ELSE IF( type.EQ.'he'.OR.type.EQ.'sy' )THEN
2690  DO 50 j = 1, n
2691  IF( upper )THEN
2692  ibeg = 1
2693  iend = j
2694  ELSE
2695  ibeg = j
2696  iend = n
2697  END IF
2698  DO 30 i = 1, ibeg - 1
2699  IF( aa( i, j ).NE.as( i, j ) )
2700  $ GO TO 70
2701  30 CONTINUE
2702  DO 40 i = iend + 1, lda
2703  IF( aa( i, j ).NE.as( i, j ) )
2704  $ GO TO 70
2705  40 CONTINUE
2706  50 CONTINUE
2707  END IF
2708 *
2709  60 CONTINUE
2710  lzeres = .true.
2711  GO TO 80
2712  70 CONTINUE
2713  lzeres = .false.
2714  80 RETURN
2715 *
2716 * End of LZERES.
2717 *
2718  END
2719  COMPLEX*16 FUNCTION zbeg( RESET )
2720 *
2721 * Generates complex numbers as pairs of random numbers uniformly
2722 * distributed between -0.5 and 0.5.
2723 *
2724 * Auxiliary routine for test program for Level 3 Blas.
2725 *
2726 * -- Written on 8-February-1989.
2727 * Jack Dongarra, Argonne National Laboratory.
2728 * Iain Duff, AERE Harwell.
2729 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2730 * Sven Hammarling, Numerical Algorithms Group Ltd.
2731 *
2732 * .. Scalar Arguments ..
2733  LOGICAL RESET
2734 * .. Local Scalars ..
2735  INTEGER I, IC, J, MI, MJ
2736 * .. Save statement ..
2737  SAVE i, ic, j, mi, mj
2738 * .. Intrinsic Functions ..
2739  INTRINSIC dcmplx
2740 * .. Executable Statements ..
2741  IF( reset )THEN
2742 * Initialize local variables.
2743  mi = 891
2744  mj = 457
2745  i = 7
2746  j = 7
2747  ic = 0
2748  reset = .false.
2749  END IF
2750 *
2751 * The sequence of values of I or J is bounded between 1 and 999.
2752 * If initial I or J = 1,2,3,6,7 or 9, the period will be 50.
2753 * If initial I or J = 4 or 8, the period will be 25.
2754 * If initial I or J = 5, the period will be 10.
2755 * IC is used to break up the period by skipping 1 value of I or J
2756 * in 6.
2757 *
2758  ic = ic + 1
2759  10 i = i*mi
2760  j = j*mj
2761  i = i - 1000*( i/1000 )
2762  j = j - 1000*( j/1000 )
2763  IF( ic.GE.5 )THEN
2764  ic = 0
2765  GO TO 10
2766  END IF
2767  zbeg = dcmplx( ( i - 500 )/1001.0d0, ( j - 500 )/1001.0d0 )
2768  RETURN
2769 *
2770 * End of ZBEG.
2771 *
2772  END
2773  DOUBLE PRECISION FUNCTION ddiff( X, Y )
2774 *
2775 * Auxiliary routine for test program for Level 3 Blas.
2776 *
2777 * -- Written on 8-February-1989.
2778 * Jack Dongarra, Argonne National Laboratory.
2779 * Iain Duff, AERE Harwell.
2780 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2781 * Sven Hammarling, Numerical Algorithms Group Ltd.
2782 *
2783 * .. Scalar Arguments ..
2784  DOUBLE PRECISION X, Y
2785 * .. Executable Statements ..
2786  ddiff = x - y
2787  RETURN
2788 *
2789 * End of DDIFF.
2790 *
2791  END
2792 
zprcn2
subroutine zprcn2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC)
Definition: c_zblat3.f:1049
zbeg
complex *16 function zbeg(RESET)
Definition: zblat2.f:3139
zprcn3
subroutine zprcn3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, LDA, LDB)
Definition: c_zblat3.f:1401
zprcn6
subroutine zprcn6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, N, K, ALPHA, LDA, BETA, LDC)
Definition: c_zblat3.f:1821
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3080
zmmch
subroutine zmmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
Definition: zblat3.f:3064
zprcn5
subroutine zprcn5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, N, K, ALPHA, LDA, LDB, BETA, LDC)
Definition: c_zblat3.f:2240
ddiff
double precision function ddiff(X, Y)
Definition: dblat2.f:3080
zprcn7
subroutine zprcn7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, N, K, ALPHA, LDA, LDB, BETA, LDC)
Definition: c_zblat3.f:2274
zchk2
subroutine zchk2(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: zblat2.f:788
zmake
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: zblat2.f:2726
zprcn4
subroutine zprcn4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, N, K, ALPHA, LDA, BETA, LDC)
Definition: c_zblat3.f:1787
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3050
zchk4
subroutine zchk4(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: zblat2.f:1499
zblat3
program zblat3
ZBLAT3
Definition: zblat3.f:87
zchk3
subroutine zchk3(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: zblat2.f:1136
zprcn1
subroutine zprcn1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, BETA, LDC)
Definition: c_zblat3.f:723
zchk5
subroutine zchk5(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: zblat2.f:1777
zchk1
subroutine zchk1(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: zblat2.f:442