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