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