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