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