LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 
schk2
subroutine schk2(SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G)
Definition: sblat2.f:775
schk5
subroutine schk5(SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, Z)
Definition: sblat2.f:1736
ssyrk
subroutine ssyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
SSYRK
Definition: ssyrk.f:171
strsm
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRSM
Definition: strsm.f:183
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2653
schk3
subroutine schk3(SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, XT, G, Z)
Definition: sblat2.f:1117
schk1
subroutine schk1(SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G)
Definition: sblat2.f:434
schke
subroutine schke(ISNUM, SRNAMT, NOUT)
Definition: sblat2.f:2326
sgemm
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
Definition: sgemm.f:189
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
schk4
subroutine schk4(SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, Z)
Definition: sblat2.f:1475
chkxer
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
Definition: cblat2.f:3199
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2945
strmm
subroutine strmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRMM
Definition: strmm.f:179
ssyr2k
subroutine ssyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SSYR2K
Definition: ssyr2k.f:194
sdiff
real function sdiff(SA, SB)
Definition: cblat1.f:645
sbeg
real function sbeg(RESET)
Definition: sblat2.f:3034
sblat3
program sblat3
SBLAT3
Definition: sblat3.f:83
lseres
logical function lseres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: sblat2.f:2975
smmch
subroutine smmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
Definition: sblat3.f:2511
ssymm
subroutine ssymm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SSYMM
Definition: ssymm.f:191