LAPACK  3.11.0
LAPACK: Linear Algebra PACKage
c_zblat3.f
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