LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
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*
38410002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
38510001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' )
38610000 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*
68410003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
685 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
686 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
68710002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
688 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
689 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
69010001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
691 $ ' (', i6, ' CALL', 'S)' )
69210000 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*
99710003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
998 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
999 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
100010002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1001 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1002 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
100310001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1004 $ ' (', i6, ' CALL', 'S)' )
100510000 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*
134510003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1346 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1347 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
134810002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1349 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1350 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
135110001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1352 $ ' (', i6, ' CALL', 'S)' )
135310000 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*
167010003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1671 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1672 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
167310002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1674 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1675 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
167610001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1677 $ ' (', i6, ' CALL', 'S)' )
167810000 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*
202610003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2027 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2028 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
202910002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2030 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2031 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
203210001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2033 $ ' (', i6, ' CALL', 'S)' )
203410000 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
dprcn3
subroutine dprcn3(nout, nc, sname, iorder, side, uplo, transa, diag, m, n, alpha, lda, ldb)
Definition c_dblat3.f:1369
dprcn2
subroutine dprcn2(nout, nc, sname, iorder, side, uplo, m, n, alpha, lda, ldb, beta, ldc)
Definition c_dblat3.f:1022
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
dprcn1
subroutine dprcn1(nout, nc, sname, iorder, transa, transb, m, n, k, alpha, lda, ldb, beta, ldc)
Definition c_dblat3.f:708
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:1500
lde
logical function lde(ri, rj, lr)
Definition dblat2.f:2970
lderes
logical function lderes(type, uplo, m, n, aa, as, lda)
Definition dblat2.f:3000
dbeg
double precision function dbeg(reset)
Definition dblat2.f:3059
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:800
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:1761
ddiff
double precision function ddiff(x, y)
Definition dblat2.f:3105
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:1142
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:431
dmake
subroutine dmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition dblat2.f:2678
dblat3
program dblat3
DBLAT3
Definition dblat3.f:81
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:2508