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