LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
dblat3.f
Go to the documentation of this file.
1 *> \brief \b DBLAT3
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 DBLAT3
12 *
13 *
14 *> \par Purpose:
15 * =============
16 *>
17 *> \verbatim
18 *>
19 *> Test program for the DOUBLE PRECISION 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 *> 'dblat3.out' NAME OF SUMMARY OUTPUT FILE
27 *> 6 UNIT NUMBER OF SUMMARY FILE
28 *> 'DBLAT3.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 *> DGEMM T PUT F FOR NO TEST. SAME COLUMNS.
41 *> DSYMM T PUT F FOR NO TEST. SAME COLUMNS.
42 *> DTRMM T PUT F FOR NO TEST. SAME COLUMNS.
43 *> DTRSM T PUT F FOR NO TEST. SAME COLUMNS.
44 *> DSYRK T PUT F FOR NO TEST. SAME COLUMNS.
45 *> DSYR2K 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 double_blas_testing
81 *
82 * =====================================================================
83  PROGRAM dblat3
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  DOUBLE PRECISION ZERO, ONE
98  parameter ( zero = 0.0d0, one = 1.0d0 )
99  INTEGER NMAX
100  parameter ( nmax = 65 )
101  INTEGER NIDMAX, NALMAX, NBEMAX
102  parameter ( nidmax = 9, nalmax = 7, nbemax = 7 )
103 * .. Local Scalars ..
104  DOUBLE PRECISION 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  DOUBLE PRECISION 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  DOUBLE PRECISION DDIFF
123  LOGICAL LDE
124  EXTERNAL ddiff, lde
125 * .. External Subroutines ..
126  EXTERNAL dchk1, dchk2, dchk3, dchk4, dchk5, dchke, dmmch
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/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ',
138  $ 'DSYRK ', 'DSYR2K'/
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, status = 'UNKNOWN' )
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, status = 'UNKNOWN' )
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 DMMCH 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 DMMCH CT holds
249 * the result computed by DMMCH.
250  transa = 'N'
251  transb = 'N'
252  CALL dmmch( 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 = lde( 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 dmmch( 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 = lde( 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 dmmch( 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 = lde( 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 dmmch( 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 = lde( 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 dchke( 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 DGEMM, 01.
317  140 CALL dchk1( 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 DSYMM, 02.
323  150 CALL dchk2( 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 DTRMM, 03, DTRSM, 04.
329  160 CALL dchk3( 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 DSYRK, 05.
334  170 CALL dchk4( 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 DSYR2K, 06.
340  180 CALL dchk5( 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, d9.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 DOUBLE PRECISION 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 DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
381  $ 'ATED WRONGLY.', /' DMMCH 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 DBLAT3.
393 *
394  END
395  SUBROUTINE dchk1( 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 DGEMM.
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  DOUBLE PRECISION ZERO
411  parameter ( zero = 0.0d0 )
412 * .. Scalar Arguments ..
413  DOUBLE PRECISION EPS, THRESH
414  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
415  LOGICAL FATAL, REWI, TRACE
416  CHARACTER*6 SNAME
417 * .. Array Arguments ..
418  DOUBLE PRECISION 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  DOUBLE PRECISION 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 LDE, LDERES
436  EXTERNAL lde, lderes
437 * .. External Subroutines ..
438  EXTERNAL dgemm, dmake, dmmch
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 dmake( '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 dmake( '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 dmake( '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 dgemm( 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 ) = lde( as, aa, laa )
587  isame( 8 ) = ldas.EQ.lda
588  isame( 9 ) = lde( bs, bb, lbb )
589  isame( 10 ) = ldbs.EQ.ldb
590  isame( 11 ) = bls.EQ.beta
591  IF( null )THEN
592  isame( 12 ) = lde( cs, cc, lcc )
593  ELSE
594  isame( 12 ) = lderes( '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 dmmch( 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 DCHK1.
674 *
675  END
676  SUBROUTINE dchk2( 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 DSYMM.
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  DOUBLE PRECISION ZERO
692  parameter ( zero = 0.0d0 )
693 * .. Scalar Arguments ..
694  DOUBLE PRECISION EPS, THRESH
695  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
696  LOGICAL FATAL, REWI, TRACE
697  CHARACTER*6 SNAME
698 * .. Array Arguments ..
699  DOUBLE PRECISION 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  DOUBLE PRECISION 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 LDE, LDERES
717  EXTERNAL lde, lderes
718 * .. External Subroutines ..
719  EXTERNAL dmake, dmmch, dsymm
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 dmake( '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 dmake( '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 dmake( '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 dsymm( 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 ) = lde( as, aa, laa )
852  isame( 7 ) = ldas.EQ.lda
853  isame( 8 ) = lde( bs, bb, lbb )
854  isame( 9 ) = ldbs.EQ.ldb
855  isame( 10 ) = bls.EQ.beta
856  IF( null )THEN
857  isame( 11 ) = lde( cs, cc, lcc )
858  ELSE
859  isame( 11 ) = lderes( '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 dmmch( '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 dmmch( '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 DCHK2.
944 *
945  END
946  SUBROUTINE dchk3( 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 DTRMM and DTRSM.
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  DOUBLE PRECISION ZERO, ONE
962  parameter ( zero = 0.0d0, one = 1.0d0 )
963 * .. Scalar Arguments ..
964  DOUBLE PRECISION EPS, THRESH
965  INTEGER NALF, NIDIM, NMAX, NOUT, NTRA
966  LOGICAL FATAL, REWI, TRACE
967  CHARACTER*6 SNAME
968 * .. Array Arguments ..
969  DOUBLE PRECISION 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  DOUBLE PRECISION 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 LDE, LDERES
988  EXTERNAL lde, lderes
989 * .. External Subroutines ..
990  EXTERNAL dmake, dmmch, dtrmm, dtrsm
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 DMMCH.
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 dmake( 'TR', uplo, diag, na, na, a,
1060  $ nmax, aa, lda, reset, zero )
1061 *
1062 * Generate the matrix B.
1063 *
1064  CALL dmake( '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 dtrmm( 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 dtrsm( 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 ) = lde( as, aa, laa )
1128  isame( 9 ) = ldas.EQ.lda
1129  IF( null )THEN
1130  isame( 10 ) = lde( bs, bb, lbb )
1131  ELSE
1132  isame( 10 ) = lderes( '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 dmmch( 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 dmmch( '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 dmmch( 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 dmmch( '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 DCHK3.
1249 *
1250  END
1251  SUBROUTINE dchk4( 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 DSYRK.
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  DOUBLE PRECISION ZERO
1267  parameter ( zero = 0.0d0 )
1268 * .. Scalar Arguments ..
1269  DOUBLE PRECISION EPS, THRESH
1270  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1271  LOGICAL FATAL, REWI, TRACE
1272  CHARACTER*6 SNAME
1273 * .. Array Arguments ..
1274  DOUBLE PRECISION 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  DOUBLE PRECISION 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 LDE, LDERES
1293  EXTERNAL lde, lderes
1294 * .. External Subroutines ..
1295  EXTERNAL dmake, dmmch, dsyrk
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 dmake( '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 dmake( '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 dsyrk( 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 ) = lde( as, aa, laa )
1411  isame( 7 ) = ldas.EQ.lda
1412  isame( 8 ) = bets.EQ.beta
1413  IF( null )THEN
1414  isame( 9 ) = lde( cs, cc, lcc )
1415  ELSE
1416  isame( 9 ) = lderes( '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 dmmch( '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 dmmch( '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 DCHK4.
1524 *
1525  END
1526  SUBROUTINE dchk5( 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 DSYR2K.
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  DOUBLE PRECISION ZERO
1542  parameter ( zero = 0.0d0 )
1543 * .. Scalar Arguments ..
1544  DOUBLE PRECISION EPS, THRESH
1545  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1546  LOGICAL FATAL, REWI, TRACE
1547  CHARACTER*6 SNAME
1548 * .. Array Arguments ..
1549  DOUBLE PRECISION 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  DOUBLE PRECISION 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 LDE, LDERES
1568  EXTERNAL lde, lderes
1569 * .. External Subroutines ..
1570  EXTERNAL dmake, dmmch, dsyr2k
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 dmake( 'GE', ' ', ' ', ma, na, ab, 2*nmax, aa,
1625  $ lda, reset, zero )
1626  ELSE
1627  CALL dmake( '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 dmake( 'GE', ' ', ' ', ma, na, ab( k + 1 ),
1637  $ 2*nmax, bb, ldb, reset, zero )
1638  ELSE
1639  CALL dmake( '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 dmake( '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 dsyr2k( 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 ) = lde( as, aa, laa )
1707  isame( 7 ) = ldas.EQ.lda
1708  isame( 8 ) = lde( bs, bb, lbb )
1709  isame( 9 ) = ldbs.EQ.ldb
1710  isame( 10 ) = bets.EQ.beta
1711  IF( null )THEN
1712  isame( 11 ) = lde( cs, cc, lcc )
1713  ELSE
1714  isame( 11 ) = lderes( '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 dmmch( '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 dmmch( '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 DCHK5.
1838 *
1839  END
1840  SUBROUTINE dchke( 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  DOUBLE PRECISION ONE, TWO
1865  parameter ( one = 1.0d0, two = 2.0d0 )
1866 * .. Local Scalars ..
1867  DOUBLE PRECISION ALPHA, BETA
1868 * .. Local Arrays ..
1869  DOUBLE PRECISION A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
1870 * .. External Subroutines ..
1871  EXTERNAL chkxer, dgemm, dsymm, dsyr2k, dsyrk, dtrmm,
1872  $ dtrsm
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 dgemm( '/', '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 dgemm( '/', '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dgemm( '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 dsymm( '/', 'U', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1976  CALL chkxer( srnamt, infot, nout, lerr, ok )
1977  infot = 2
1978  CALL dsymm( 'L', '/', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1979  CALL chkxer( srnamt, infot, nout, lerr, ok )
1980  infot = 3
1981  CALL dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dsymm( '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 dtrmm( '/', 'U', 'N', 'N', 0, 0, alpha, a, 1, b, 1 )
2043  CALL chkxer( srnamt, infot, nout, lerr, ok )
2044  infot = 2
2045  CALL dtrmm( 'L', '/', 'N', 'N', 0, 0, alpha, a, 1, b, 1 )
2046  CALL chkxer( srnamt, infot, nout, lerr, ok )
2047  infot = 3
2048  CALL dtrmm( 'L', 'U', '/', 'N', 0, 0, alpha, a, 1, b, 1 )
2049  CALL chkxer( srnamt, infot, nout, lerr, ok )
2050  infot = 4
2051  CALL dtrmm( 'L', 'U', 'N', '/', 0, 0, alpha, a, 1, b, 1 )
2052  CALL chkxer( srnamt, infot, nout, lerr, ok )
2053  infot = 5
2054  CALL dtrmm( 'L', 'U', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2055  CALL chkxer( srnamt, infot, nout, lerr, ok )
2056  infot = 5
2057  CALL dtrmm( 'L', 'U', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2058  CALL chkxer( srnamt, infot, nout, lerr, ok )
2059  infot = 5
2060  CALL dtrmm( 'R', 'U', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2061  CALL chkxer( srnamt, infot, nout, lerr, ok )
2062  infot = 5
2063  CALL dtrmm( 'R', 'U', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2064  CALL chkxer( srnamt, infot, nout, lerr, ok )
2065  infot = 5
2066  CALL dtrmm( 'L', 'L', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2067  CALL chkxer( srnamt, infot, nout, lerr, ok )
2068  infot = 5
2069  CALL dtrmm( 'L', 'L', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2070  CALL chkxer( srnamt, infot, nout, lerr, ok )
2071  infot = 5
2072  CALL dtrmm( 'R', 'L', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2073  CALL chkxer( srnamt, infot, nout, lerr, ok )
2074  infot = 5
2075  CALL dtrmm( 'R', 'L', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2076  CALL chkxer( srnamt, infot, nout, lerr, ok )
2077  infot = 6
2078  CALL dtrmm( 'L', 'U', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2079  CALL chkxer( srnamt, infot, nout, lerr, ok )
2080  infot = 6
2081  CALL dtrmm( 'L', 'U', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2082  CALL chkxer( srnamt, infot, nout, lerr, ok )
2083  infot = 6
2084  CALL dtrmm( 'R', 'U', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2085  CALL chkxer( srnamt, infot, nout, lerr, ok )
2086  infot = 6
2087  CALL dtrmm( 'R', 'U', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2088  CALL chkxer( srnamt, infot, nout, lerr, ok )
2089  infot = 6
2090  CALL dtrmm( 'L', 'L', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2091  CALL chkxer( srnamt, infot, nout, lerr, ok )
2092  infot = 6
2093  CALL dtrmm( 'L', 'L', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2094  CALL chkxer( srnamt, infot, nout, lerr, ok )
2095  infot = 6
2096  CALL dtrmm( 'R', 'L', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2097  CALL chkxer( srnamt, infot, nout, lerr, ok )
2098  infot = 6
2099  CALL dtrmm( 'R', 'L', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2100  CALL chkxer( srnamt, infot, nout, lerr, ok )
2101  infot = 9
2102  CALL dtrmm( 'L', 'U', 'N', 'N', 2, 0, alpha, a, 1, b, 2 )
2103  CALL chkxer( srnamt, infot, nout, lerr, ok )
2104  infot = 9
2105  CALL dtrmm( 'L', 'U', 'T', 'N', 2, 0, alpha, a, 1, b, 2 )
2106  CALL chkxer( srnamt, infot, nout, lerr, ok )
2107  infot = 9
2108  CALL dtrmm( 'R', 'U', 'N', 'N', 0, 2, alpha, a, 1, b, 1 )
2109  CALL chkxer( srnamt, infot, nout, lerr, ok )
2110  infot = 9
2111  CALL dtrmm( 'R', 'U', 'T', 'N', 0, 2, alpha, a, 1, b, 1 )
2112  CALL chkxer( srnamt, infot, nout, lerr, ok )
2113  infot = 9
2114  CALL dtrmm( 'L', 'L', 'N', 'N', 2, 0, alpha, a, 1, b, 2 )
2115  CALL chkxer( srnamt, infot, nout, lerr, ok )
2116  infot = 9
2117  CALL dtrmm( 'L', 'L', 'T', 'N', 2, 0, alpha, a, 1, b, 2 )
2118  CALL chkxer( srnamt, infot, nout, lerr, ok )
2119  infot = 9
2120  CALL dtrmm( 'R', 'L', 'N', 'N', 0, 2, alpha, a, 1, b, 1 )
2121  CALL chkxer( srnamt, infot, nout, lerr, ok )
2122  infot = 9
2123  CALL dtrmm( 'R', 'L', 'T', 'N', 0, 2, alpha, a, 1, b, 1 )
2124  CALL chkxer( srnamt, infot, nout, lerr, ok )
2125  infot = 11
2126  CALL dtrmm( 'L', 'U', 'N', 'N', 2, 0, alpha, a, 2, b, 1 )
2127  CALL chkxer( srnamt, infot, nout, lerr, ok )
2128  infot = 11
2129  CALL dtrmm( 'L', 'U', 'T', 'N', 2, 0, alpha, a, 2, b, 1 )
2130  CALL chkxer( srnamt, infot, nout, lerr, ok )
2131  infot = 11
2132  CALL dtrmm( 'R', 'U', 'N', 'N', 2, 0, alpha, a, 1, b, 1 )
2133  CALL chkxer( srnamt, infot, nout, lerr, ok )
2134  infot = 11
2135  CALL dtrmm( 'R', 'U', 'T', 'N', 2, 0, alpha, a, 1, b, 1 )
2136  CALL chkxer( srnamt, infot, nout, lerr, ok )
2137  infot = 11
2138  CALL dtrmm( 'L', 'L', 'N', 'N', 2, 0, alpha, a, 2, b, 1 )
2139  CALL chkxer( srnamt, infot, nout, lerr, ok )
2140  infot = 11
2141  CALL dtrmm( 'L', 'L', 'T', 'N', 2, 0, alpha, a, 2, b, 1 )
2142  CALL chkxer( srnamt, infot, nout, lerr, ok )
2143  infot = 11
2144  CALL dtrmm( 'R', 'L', 'N', 'N', 2, 0, alpha, a, 1, b, 1 )
2145  CALL chkxer( srnamt, infot, nout, lerr, ok )
2146  infot = 11
2147  CALL dtrmm( '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 dtrsm( '/', 'U', 'N', 'N', 0, 0, alpha, a, 1, b, 1 )
2152  CALL chkxer( srnamt, infot, nout, lerr, ok )
2153  infot = 2
2154  CALL dtrsm( 'L', '/', 'N', 'N', 0, 0, alpha, a, 1, b, 1 )
2155  CALL chkxer( srnamt, infot, nout, lerr, ok )
2156  infot = 3
2157  CALL dtrsm( 'L', 'U', '/', 'N', 0, 0, alpha, a, 1, b, 1 )
2158  CALL chkxer( srnamt, infot, nout, lerr, ok )
2159  infot = 4
2160  CALL dtrsm( 'L', 'U', 'N', '/', 0, 0, alpha, a, 1, b, 1 )
2161  CALL chkxer( srnamt, infot, nout, lerr, ok )
2162  infot = 5
2163  CALL dtrsm( 'L', 'U', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2164  CALL chkxer( srnamt, infot, nout, lerr, ok )
2165  infot = 5
2166  CALL dtrsm( 'L', 'U', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2167  CALL chkxer( srnamt, infot, nout, lerr, ok )
2168  infot = 5
2169  CALL dtrsm( 'R', 'U', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2170  CALL chkxer( srnamt, infot, nout, lerr, ok )
2171  infot = 5
2172  CALL dtrsm( 'R', 'U', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2173  CALL chkxer( srnamt, infot, nout, lerr, ok )
2174  infot = 5
2175  CALL dtrsm( 'L', 'L', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2176  CALL chkxer( srnamt, infot, nout, lerr, ok )
2177  infot = 5
2178  CALL dtrsm( 'L', 'L', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2179  CALL chkxer( srnamt, infot, nout, lerr, ok )
2180  infot = 5
2181  CALL dtrsm( 'R', 'L', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2182  CALL chkxer( srnamt, infot, nout, lerr, ok )
2183  infot = 5
2184  CALL dtrsm( 'R', 'L', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2185  CALL chkxer( srnamt, infot, nout, lerr, ok )
2186  infot = 6
2187  CALL dtrsm( 'L', 'U', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2188  CALL chkxer( srnamt, infot, nout, lerr, ok )
2189  infot = 6
2190  CALL dtrsm( 'L', 'U', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2191  CALL chkxer( srnamt, infot, nout, lerr, ok )
2192  infot = 6
2193  CALL dtrsm( 'R', 'U', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2194  CALL chkxer( srnamt, infot, nout, lerr, ok )
2195  infot = 6
2196  CALL dtrsm( 'R', 'U', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2197  CALL chkxer( srnamt, infot, nout, lerr, ok )
2198  infot = 6
2199  CALL dtrsm( 'L', 'L', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2200  CALL chkxer( srnamt, infot, nout, lerr, ok )
2201  infot = 6
2202  CALL dtrsm( 'L', 'L', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2203  CALL chkxer( srnamt, infot, nout, lerr, ok )
2204  infot = 6
2205  CALL dtrsm( 'R', 'L', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2206  CALL chkxer( srnamt, infot, nout, lerr, ok )
2207  infot = 6
2208  CALL dtrsm( 'R', 'L', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2209  CALL chkxer( srnamt, infot, nout, lerr, ok )
2210  infot = 9
2211  CALL dtrsm( 'L', 'U', 'N', 'N', 2, 0, alpha, a, 1, b, 2 )
2212  CALL chkxer( srnamt, infot, nout, lerr, ok )
2213  infot = 9
2214  CALL dtrsm( 'L', 'U', 'T', 'N', 2, 0, alpha, a, 1, b, 2 )
2215  CALL chkxer( srnamt, infot, nout, lerr, ok )
2216  infot = 9
2217  CALL dtrsm( 'R', 'U', 'N', 'N', 0, 2, alpha, a, 1, b, 1 )
2218  CALL chkxer( srnamt, infot, nout, lerr, ok )
2219  infot = 9
2220  CALL dtrsm( 'R', 'U', 'T', 'N', 0, 2, alpha, a, 1, b, 1 )
2221  CALL chkxer( srnamt, infot, nout, lerr, ok )
2222  infot = 9
2223  CALL dtrsm( 'L', 'L', 'N', 'N', 2, 0, alpha, a, 1, b, 2 )
2224  CALL chkxer( srnamt, infot, nout, lerr, ok )
2225  infot = 9
2226  CALL dtrsm( 'L', 'L', 'T', 'N', 2, 0, alpha, a, 1, b, 2 )
2227  CALL chkxer( srnamt, infot, nout, lerr, ok )
2228  infot = 9
2229  CALL dtrsm( 'R', 'L', 'N', 'N', 0, 2, alpha, a, 1, b, 1 )
2230  CALL chkxer( srnamt, infot, nout, lerr, ok )
2231  infot = 9
2232  CALL dtrsm( 'R', 'L', 'T', 'N', 0, 2, alpha, a, 1, b, 1 )
2233  CALL chkxer( srnamt, infot, nout, lerr, ok )
2234  infot = 11
2235  CALL dtrsm( 'L', 'U', 'N', 'N', 2, 0, alpha, a, 2, b, 1 )
2236  CALL chkxer( srnamt, infot, nout, lerr, ok )
2237  infot = 11
2238  CALL dtrsm( 'L', 'U', 'T', 'N', 2, 0, alpha, a, 2, b, 1 )
2239  CALL chkxer( srnamt, infot, nout, lerr, ok )
2240  infot = 11
2241  CALL dtrsm( 'R', 'U', 'N', 'N', 2, 0, alpha, a, 1, b, 1 )
2242  CALL chkxer( srnamt, infot, nout, lerr, ok )
2243  infot = 11
2244  CALL dtrsm( 'R', 'U', 'T', 'N', 2, 0, alpha, a, 1, b, 1 )
2245  CALL chkxer( srnamt, infot, nout, lerr, ok )
2246  infot = 11
2247  CALL dtrsm( 'L', 'L', 'N', 'N', 2, 0, alpha, a, 2, b, 1 )
2248  CALL chkxer( srnamt, infot, nout, lerr, ok )
2249  infot = 11
2250  CALL dtrsm( 'L', 'L', 'T', 'N', 2, 0, alpha, a, 2, b, 1 )
2251  CALL chkxer( srnamt, infot, nout, lerr, ok )
2252  infot = 11
2253  CALL dtrsm( 'R', 'L', 'N', 'N', 2, 0, alpha, a, 1, b, 1 )
2254  CALL chkxer( srnamt, infot, nout, lerr, ok )
2255  infot = 11
2256  CALL dtrsm( '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 dsyrk( '/', 'N', 0, 0, alpha, a, 1, beta, c, 1 )
2261  CALL chkxer( srnamt, infot, nout, lerr, ok )
2262  infot = 2
2263  CALL dsyrk( 'U', '/', 0, 0, alpha, a, 1, beta, c, 1 )
2264  CALL chkxer( srnamt, infot, nout, lerr, ok )
2265  infot = 3
2266  CALL dsyrk( 'U', 'N', -1, 0, alpha, a, 1, beta, c, 1 )
2267  CALL chkxer( srnamt, infot, nout, lerr, ok )
2268  infot = 3
2269  CALL dsyrk( 'U', 'T', -1, 0, alpha, a, 1, beta, c, 1 )
2270  CALL chkxer( srnamt, infot, nout, lerr, ok )
2271  infot = 3
2272  CALL dsyrk( 'L', 'N', -1, 0, alpha, a, 1, beta, c, 1 )
2273  CALL chkxer( srnamt, infot, nout, lerr, ok )
2274  infot = 3
2275  CALL dsyrk( 'L', 'T', -1, 0, alpha, a, 1, beta, c, 1 )
2276  CALL chkxer( srnamt, infot, nout, lerr, ok )
2277  infot = 4
2278  CALL dsyrk( 'U', 'N', 0, -1, alpha, a, 1, beta, c, 1 )
2279  CALL chkxer( srnamt, infot, nout, lerr, ok )
2280  infot = 4
2281  CALL dsyrk( 'U', 'T', 0, -1, alpha, a, 1, beta, c, 1 )
2282  CALL chkxer( srnamt, infot, nout, lerr, ok )
2283  infot = 4
2284  CALL dsyrk( 'L', 'N', 0, -1, alpha, a, 1, beta, c, 1 )
2285  CALL chkxer( srnamt, infot, nout, lerr, ok )
2286  infot = 4
2287  CALL dsyrk( 'L', 'T', 0, -1, alpha, a, 1, beta, c, 1 )
2288  CALL chkxer( srnamt, infot, nout, lerr, ok )
2289  infot = 7
2290  CALL dsyrk( 'U', 'N', 2, 0, alpha, a, 1, beta, c, 2 )
2291  CALL chkxer( srnamt, infot, nout, lerr, ok )
2292  infot = 7
2293  CALL dsyrk( 'U', 'T', 0, 2, alpha, a, 1, beta, c, 1 )
2294  CALL chkxer( srnamt, infot, nout, lerr, ok )
2295  infot = 7
2296  CALL dsyrk( 'L', 'N', 2, 0, alpha, a, 1, beta, c, 2 )
2297  CALL chkxer( srnamt, infot, nout, lerr, ok )
2298  infot = 7
2299  CALL dsyrk( 'L', 'T', 0, 2, alpha, a, 1, beta, c, 1 )
2300  CALL chkxer( srnamt, infot, nout, lerr, ok )
2301  infot = 10
2302  CALL dsyrk( 'U', 'N', 2, 0, alpha, a, 2, beta, c, 1 )
2303  CALL chkxer( srnamt, infot, nout, lerr, ok )
2304  infot = 10
2305  CALL dsyrk( 'U', 'T', 2, 0, alpha, a, 1, beta, c, 1 )
2306  CALL chkxer( srnamt, infot, nout, lerr, ok )
2307  infot = 10
2308  CALL dsyrk( 'L', 'N', 2, 0, alpha, a, 2, beta, c, 1 )
2309  CALL chkxer( srnamt, infot, nout, lerr, ok )
2310  infot = 10
2311  CALL dsyrk( '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 dsyr2k( '/', 'N', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
2316  CALL chkxer( srnamt, infot, nout, lerr, ok )
2317  infot = 2
2318  CALL dsyr2k( 'U', '/', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
2319  CALL chkxer( srnamt, infot, nout, lerr, ok )
2320  infot = 3
2321  CALL dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 dsyr2k( '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 DCHKE.
2393 *
2394  END
2395  SUBROUTINE dmake( 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  DOUBLE PRECISION ZERO, ONE
2414  parameter ( zero = 0.0d0, one = 1.0d0 )
2415  DOUBLE PRECISION ROGUE
2416  parameter ( rogue = -1.0d10 )
2417 * .. Scalar Arguments ..
2418  DOUBLE PRECISION TRANSL
2419  INTEGER LDA, M, N, NMAX
2420  LOGICAL RESET
2421  CHARACTER*1 DIAG, UPLO
2422  CHARACTER*2 TYPE
2423 * .. Array Arguments ..
2424  DOUBLE PRECISION A( nmax, * ), AA( * )
2425 * .. Local Scalars ..
2426  INTEGER I, IBEG, IEND, J
2427  LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2428 * .. External Functions ..
2429  DOUBLE PRECISION DBEG
2430  EXTERNAL dbeg
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 ) = dbeg( 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 DMAKE.
2506 *
2507  END
2508  SUBROUTINE dmmch( 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  DOUBLE PRECISION ZERO, ONE
2524  parameter ( zero = 0.0d0, one = 1.0d0 )
2525 * .. Scalar Arguments ..
2526  DOUBLE PRECISION 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  DOUBLE PRECISION A( lda, * ), B( ldb, * ), C( ldc, * ),
2532  $ cc( ldcc, * ), ct( * ), g( * )
2533 * .. Local Scalars ..
2534  DOUBLE PRECISION 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 DMMCH.
2628 *
2629  END
2630  LOGICAL FUNCTION lde( 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  DOUBLE PRECISION 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  lde = .true.
2654  GO TO 30
2655  20 CONTINUE
2656  lde = .false.
2657  30 RETURN
2658 *
2659 * End of LDE.
2660 *
2661  END
2662  LOGICAL FUNCTION lderes( 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  DOUBLE PRECISION 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  lderes = .true.
2715  GO TO 80
2716  70 CONTINUE
2717  lderes = .false.
2718  80 RETURN
2719 *
2720 * End of LDERES.
2721 *
2722  END
2723  DOUBLE PRECISION FUNCTION dbeg( 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  dbeg = ( i - 500 )/1001.0d0
2764  RETURN
2765 *
2766 * End of DBEG.
2767 *
2768  END
2769  DOUBLE PRECISION FUNCTION ddiff( 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  DOUBLE PRECISION X, Y
2781 * .. Executable Statements ..
2782  ddiff = x - y
2783  RETURN
2784 *
2785 * End of DDIFF.
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 
dchk4
subroutine dchk4(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: dblat2.f:1475
dtrsm
subroutine dtrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
DTRSM
Definition: dtrsm.f:183
dchk3
subroutine dchk3(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: dblat2.f:1117
dchk1
subroutine dchk1(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: dblat2.f:434
dsymm
subroutine dsymm(SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DSYMM
Definition: dsymm.f:191
dtrmm
subroutine dtrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
DTRMM
Definition: dtrmm.f:179
dmake
subroutine dmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: dblat2.f:2653
dmmch
subroutine dmmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
Definition: dblat3.f:2511
lde
logical function lde(RI, RJ, LR)
Definition: dblat2.f:2945
ddiff
double precision function ddiff(X, Y)
Definition: dblat2.f:3080
dsyr2k
subroutine dsyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DSYR2K
Definition: dsyr2k.f:194
dgemm
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
Definition: dgemm.f:189
dsyrk
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
Definition: dsyrk.f:171
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
dchk5
subroutine dchk5(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: dblat2.f:1736
chkxer
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
Definition: cblat2.f:3199
dchk2
subroutine dchk2(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: dblat2.f:775
dchke
subroutine dchke(ISNUM, SRNAMT, NOUT)
Definition: dblat2.f:2326
dbeg
double precision function dbeg(RESET)
Definition: dblat2.f:3034
dblat3
program dblat3
DBLAT3
Definition: dblat3.f:83
lderes
logical function lderes(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: dblat2.f:2975