LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
dblat3.f
Go to the documentation of this file.
1*> \brief \b DBLAT3
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8* Definition:
9* ===========
10*
11* PROGRAM DBLAT3
12*
13*
14*> \par Purpose:
15* =============
16*>
17*> \verbatim
18*>
19*> Test program for the DOUBLE PRECISION Level 3 Blas.
20*>
21*> The program must be driven by a short data file. The first 14 records
22*> of the file are read using list-directed input, the last 7 records
23*> are read using the format ( A6, L2 ). An annotated example of a data
24*> file can be obtained by deleting the first 3 characters from the
25*> following 21 lines:
26*> 'dblat3.out' NAME OF SUMMARY OUTPUT FILE
27*> 6 UNIT NUMBER OF SUMMARY FILE
28*> 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
29*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
30*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
31*> F LOGICAL FLAG, T TO STOP ON FAILURES.
32*> T LOGICAL FLAG, T TO TEST ERROR EXITS.
33*> 16.0 THRESHOLD VALUE OF TEST RATIO
34*> 6 NUMBER OF VALUES OF N
35*> 0 1 2 3 5 9 VALUES OF N
36*> 3 NUMBER OF VALUES OF ALPHA
37*> 0.0 1.0 0.7 VALUES OF ALPHA
38*> 3 NUMBER OF VALUES OF BETA
39*> 0.0 1.0 1.3 VALUES OF BETA
40*> DGEMM T PUT F FOR NO TEST. SAME COLUMNS.
41*> DSYMM T PUT F FOR NO TEST. SAME COLUMNS.
42*> DTRMM T PUT F FOR NO TEST. SAME COLUMNS.
43*> DTRSM T PUT F FOR NO TEST. SAME COLUMNS.
44*> DSYRK T PUT F FOR NO TEST. SAME COLUMNS.
45*> DSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
46*> DGEMMTR T PUT F FOR NO TEST. SAME COLUMNS.
47*>
48*> Further Details
49*> ===============
50*>
51*> See:
52*>
53*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
54*> A Set of Level 3 Basic Linear Algebra Subprograms.
55*>
56*> Technical Memorandum No.88 (Revision 1), Mathematics and
57*> Computer Science Division, Argonne National Laboratory, 9700
58*> South Cass Avenue, Argonne, Illinois 60439, US.
59*>
60*> -- Written on 8-February-1989.
61*> Jack Dongarra, Argonne National Laboratory.
62*> Iain Duff, AERE Harwell.
63*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
64*> Sven Hammarling, Numerical Algorithms Group Ltd.
65*>
66*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
67*> can be run multiple times without deleting generated
68*> output files (susan)
69*> \endverbatim
70*
71* Authors:
72* ========
73*
74*> \author Univ. of Tennessee
75*> \author Univ. of California Berkeley
76*> \author Univ. of Colorado Denver
77*> \author NAG Ltd.
78*
79*> \ingroup double_blas_testing
80*
81* =====================================================================
82 PROGRAM dblat3
83*
84* -- Reference BLAS test routine --
85* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
86* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
87*
88* =====================================================================
89*
90* .. Parameters ..
91 INTEGER nin
92 parameter( nin = 5 )
93 INTEGER nsubs
94 parameter( nsubs = 7 )
95 DOUBLE PRECISION zero, one
96 parameter( zero = 0.0d0, one = 1.0d0 )
97 INTEGER nmax
98 parameter( nmax = 65 )
99 INTEGER nidmax, nalmax, nbemax
100 parameter( nidmax = 9, nalmax = 7, nbemax = 7 )
101* .. Local Scalars ..
102 DOUBLE PRECISION eps, err, thresh
103 INTEGER i, isnum, j, n, nalf, nbet, nidim, nout, ntra
104 LOGICAL fatal, ltestt, rewi, same, sfatal, trace,
105 $ tsterr
106 CHARACTER*1 transa, transb
107 CHARACTER*7 snamet
108 CHARACTER*32 snaps, summry
109* .. Local Arrays ..
110 DOUBLE PRECISION aa( nmax*nmax ), ab( nmax, 2*nmax ),
111 $ alf( nalmax ), as( nmax*nmax ),
112 $ bb( nmax*nmax ), bet( nbemax ),
113 $ bs( nmax*nmax ), c( nmax, nmax ),
114 $ cc( nmax*nmax ), cs( nmax*nmax ), ct( nmax ),
115 $ g( nmax ), w( 2*nmax )
116 INTEGER idim( nidmax )
117 LOGICAL ltest( nsubs )
118 CHARACTER*7 snames( nsubs )
119* .. External Functions ..
120 DOUBLE PRECISION ddiff
121 LOGICAL lde
122 EXTERNAL ddiff, lde
123* .. External Subroutines ..
124 EXTERNAL dchk1, dchk2, dchk3, dchk4, dchk5, dchke, dmmch
125* .. Intrinsic Functions ..
126 INTRINSIC max, min
127* .. Scalars in Common ..
128 INTEGER infot, noutc
129 LOGICAL lerr, ok
130 CHARACTER*7 srnamt
131* .. Common blocks ..
132 COMMON /infoc/infot, noutc, ok, lerr
133 COMMON /srnamc/srnamt
134* .. Data statements ..
135 DATA snames/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ',
136 $ 'DSYRK ', 'DSYR2K', 'DGEMMTR'/
137* .. Executable Statements ..
138*
139* Read name and unit number for summary output file and open file.
140*
141 READ( nin, fmt = * )summry
142 READ( nin, fmt = * )nout
143 OPEN( nout, file = summry, status = 'UNKNOWN' )
144 noutc = nout
145*
146* Read name and unit number for snapshot output file and open file.
147*
148 READ( nin, fmt = * )snaps
149 READ( nin, fmt = * )ntra
150 trace = ntra.GE.0
151 IF( trace )THEN
152 OPEN( ntra, file = snaps, status = 'UNKNOWN' )
153 END IF
154* Read the flag that directs rewinding of the snapshot file.
155 READ( nin, fmt = * )rewi
156 rewi = rewi.AND.trace
157* Read the flag that directs stopping on any failure.
158 READ( nin, fmt = * )sfatal
159* Read the flag that indicates whether error exits are to be tested.
160 READ( nin, fmt = * )tsterr
161* Read the threshold value of the test ratio
162 READ( nin, fmt = * )thresh
163*
164* Read and check the parameter values for the tests.
165*
166* Values of N
167 READ( nin, fmt = * )nidim
168 IF( nidim.LT.1.OR.nidim.GT.nidmax )THEN
169 WRITE( nout, fmt = 9997 )'N', nidmax
170 GO TO 220
171 END IF
172 READ( nin, fmt = * )( idim( i ), i = 1, nidim )
173 DO 10 i = 1, nidim
174 IF( idim( i ).LT.0.OR.idim( i ).GT.nmax )THEN
175 WRITE( nout, fmt = 9996 )nmax
176 GO TO 220
177 END IF
178 10 CONTINUE
179* Values of ALPHA
180 READ( nin, fmt = * )nalf
181 IF( nalf.LT.1.OR.nalf.GT.nalmax )THEN
182 WRITE( nout, fmt = 9997 )'ALPHA', nalmax
183 GO TO 220
184 END IF
185 READ( nin, fmt = * )( alf( i ), i = 1, nalf )
186* Values of BETA
187 READ( nin, fmt = * )nbet
188 IF( nbet.LT.1.OR.nbet.GT.nbemax )THEN
189 WRITE( nout, fmt = 9997 )'BETA', nbemax
190 GO TO 220
191 END IF
192 READ( nin, fmt = * )( bet( i ), i = 1, nbet )
193*
194* Report values of parameters.
195*
196 WRITE( nout, fmt = 9995 )
197 WRITE( nout, fmt = 9994 )( idim( i ), i = 1, nidim )
198 WRITE( nout, fmt = 9993 )( alf( i ), i = 1, nalf )
199 WRITE( nout, fmt = 9992 )( bet( i ), i = 1, nbet )
200 IF( .NOT.tsterr )THEN
201 WRITE( nout, fmt = * )
202 WRITE( nout, fmt = 9984 )
203 END IF
204 WRITE( nout, fmt = * )
205 WRITE( nout, fmt = 9999 )thresh
206 WRITE( nout, fmt = * )
207*
208* Read names of subroutines and flags which indicate
209* whether they are to be tested.
210*
211 DO 20 i = 1, nsubs
212 ltest( i ) = .false.
213 20 CONTINUE
214 30 READ( nin, fmt = 9988, END = 60 )SNAMET, ltestt
215 DO 40 i = 1, nsubs
216 IF( snamet.EQ.snames( i ) )
217 $ GO TO 50
218 40 CONTINUE
219 WRITE( nout, fmt = 9990 )snamet
220 stop
221 50 ltest( i ) = ltestt
222 GO TO 30
223*
224 60 CONTINUE
225 CLOSE ( nin )
226*
227* Compute EPS (the machine precision).
228*
229 eps = epsilon(zero)
230 WRITE( nout, fmt = 9998 )eps
231*
232* Check the reliability of DMMCH using exact data.
233*
234 n = min( 32, nmax )
235 DO 100 j = 1, n
236 DO 90 i = 1, n
237 ab( i, j ) = max( i - j + 1, 0 )
238 90 CONTINUE
239 ab( j, nmax + 1 ) = j
240 ab( 1, nmax + j ) = j
241 c( j, 1 ) = zero
242 100 CONTINUE
243 DO 110 j = 1, n
244 cc( j ) = j*( ( j + 1 )*j )/2 - ( ( j + 1 )*j*( j - 1 ) )/3
245 110 CONTINUE
246* CC holds the exact result. On exit from DMMCH CT holds
247* the result computed by DMMCH.
248 transa = 'N'
249 transb = 'N'
250 CALL dmmch( transa, transb, n, 1, n, one, ab, nmax,
251 $ ab( 1, nmax + 1 ), nmax, zero, c, nmax, ct, g, cc,
252 $ nmax, eps, err, fatal, nout, .true. )
253 same = lde( cc, ct, n )
254 IF( .NOT.same.OR.err.NE.zero )THEN
255 WRITE( nout, fmt = 9989 )transa, transb, same, err
256 stop
257 END IF
258 transb = 'T'
259 CALL dmmch( transa, transb, n, 1, n, one, ab, nmax,
260 $ ab( 1, nmax + 1 ), nmax, zero, c, nmax, ct, g, cc,
261 $ nmax, eps, err, fatal, nout, .true. )
262 same = lde( cc, ct, n )
263 IF( .NOT.same.OR.err.NE.zero )THEN
264 WRITE( nout, fmt = 9989 )transa, transb, same, err
265 stop
266 END IF
267 DO 120 j = 1, n
268 ab( j, nmax + 1 ) = n - j + 1
269 ab( 1, nmax + j ) = n - j + 1
270 120 CONTINUE
271 DO 130 j = 1, n
272 cc( n - j + 1 ) = j*( ( j + 1 )*j )/2 -
273 $ ( ( j + 1 )*j*( j - 1 ) )/3
274 130 CONTINUE
275 transa = 'T'
276 transb = 'N'
277 CALL dmmch( transa, transb, n, 1, n, one, ab, nmax,
278 $ ab( 1, nmax + 1 ), nmax, zero, c, nmax, ct, g, cc,
279 $ nmax, eps, err, fatal, nout, .true. )
280 same = lde( cc, ct, n )
281 IF( .NOT.same.OR.err.NE.zero )THEN
282 WRITE( nout, fmt = 9989 )transa, transb, same, err
283 stop
284 END IF
285 transb = 'T'
286 CALL dmmch( transa, transb, n, 1, n, one, ab, nmax,
287 $ ab( 1, nmax + 1 ), nmax, zero, c, nmax, ct, g, cc,
288 $ nmax, eps, err, fatal, nout, .true. )
289 same = lde( cc, ct, n )
290 IF( .NOT.same.OR.err.NE.zero )THEN
291 WRITE( nout, fmt = 9989 )transa, transb, same, err
292 stop
293 END IF
294*
295* Test each subroutine in turn.
296*
297 DO 200 isnum = 1, nsubs
298 WRITE( nout, fmt = * )
299 IF( .NOT.ltest( isnum ) )THEN
300* Subprogram is not to be tested.
301 WRITE( nout, fmt = 9987 )snames( isnum )
302 ELSE
303 srnamt = snames( isnum )
304* Test error exits.
305 IF( tsterr )THEN
306 CALL dchke( isnum, snames( isnum ), nout )
307 WRITE( nout, fmt = * )
308 END IF
309* Test computations.
310 infot = 0
311 ok = .true.
312 fatal = .false.
313 GO TO ( 140, 150, 160, 160, 170, 180, 185 )isnum
314* Test DGEMM, 01.
315 140 CALL dchk1( 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 )
319 GO TO 190
320* Test DSYMM, 02.
321 150 CALL dchk2( snames( isnum ), eps, thresh, nout, ntra, trace,
322 $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
323 $ nmax, ab, aa, as, ab( 1, nmax + 1 ), bb, bs, c,
324 $ cc, cs, ct, g )
325 GO TO 190
326* Test DTRMM, 03, DTRSM, 04.
327 160 CALL dchk3( snames( isnum ), eps, thresh, nout, ntra, trace,
328 $ rewi, fatal, nidim, idim, nalf, alf, nmax, ab,
329 $ aa, as, ab( 1, nmax + 1 ), bb, bs, ct, g, c )
330 GO TO 190
331* Test DSYRK, 05.
332 170 CALL dchk4( snames( isnum ), eps, thresh, nout, ntra, trace,
333 $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
334 $ nmax, ab, aa, as, ab( 1, nmax + 1 ), bb, bs, c,
335 $ cc, cs, ct, g )
336 GO TO 190
337* Test DSYR2K, 06.
338 180 CALL dchk5( snames( isnum ), eps, thresh, nout, ntra, trace,
339 $ rewi, fatal, nidim, idim, nalf, alf, nbet, bet,
340 $ nmax, ab, aa, as, bb, bs, c, cc, cs, ct, g, w )
341 GO TO 190
342* Test DGEMMTR, 07.
343 185 CALL dchk6( 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 )
347
348*
349 190 IF( fatal.AND.sfatal )
350 $ GO TO 210
351 END IF
352 200 CONTINUE
353 WRITE( nout, fmt = 9986 )
354 GO TO 230
355*
356 210 CONTINUE
357 WRITE( nout, fmt = 9985 )
358 GO TO 230
359*
360 220 CONTINUE
361 WRITE( nout, fmt = 9991 )
362*
363 230 CONTINUE
364 IF( trace )
365 $ CLOSE ( ntra )
366 CLOSE ( nout )
367 stop
368*
369 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
370 $ 'S THAN', f8.2 )
371 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1p, d9.1 )
372 9997 FORMAT( ' NUMBER OF VALUES OF ', a, ' IS LESS THAN 1 OR GREATER ',
373 $ 'THAN ', i2 )
374 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', i2 )
375 9995 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS', //' THE F',
376 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
377 9994 FORMAT( ' FOR N ', 9i6 )
378 9993 FORMAT( ' FOR ALPHA ', 7f6.1 )
379 9992 FORMAT( ' FOR BETA ', 7f6.1 )
380 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
381 $ /' ******* TESTS ABANDONED *******' )
382 9990 FORMAT( ' SUBPROGRAM NAME ', a6, ' NOT RECOGNIZED', /' ******* T',
383 $ 'ESTS ABANDONED *******' )
384 9989 FORMAT( ' ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
385 $ 'ATED WRONGLY.', /' DMMCH WAS CALLED WITH TRANSA = ', a1,
386 $ ' AND TRANSB = ', a1, /' AND RETURNED SAME = ', l1, ' AND ',
387 $ 'ERR = ', f12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
388 $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
389 $ '*******' )
390 9988 FORMAT( a7, l2 )
391 9987 FORMAT( 1x, a7, ' WAS NOT TESTED' )
392 9986 FORMAT( /' END OF TESTS' )
393 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
394 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
395*
396* End of DBLAT3
397*
398 END
399 SUBROUTINE dchk1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
400 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
401 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
402*
403* Tests DGEMM.
404*
405* Auxiliary routine for test program for Level 3 Blas.
406*
407* -- Written on 8-February-1989.
408* Jack Dongarra, Argonne National Laboratory.
409* Iain Duff, AERE Harwell.
410* Jeremy Du Croz, Numerical Algorithms Group Ltd.
411* Sven Hammarling, Numerical Algorithms Group Ltd.
412*
413* .. Parameters ..
414 DOUBLE PRECISION ZERO
415 PARAMETER ( ZERO = 0.0d0 )
416* .. Scalar Arguments ..
417 DOUBLE PRECISION EPS, THRESH
418 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
419 LOGICAL FATAL, REWI, TRACE
420 CHARACTER*7 SNAME
421* .. Array Arguments ..
422 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
423 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
424 $ bb( nmax*nmax ), bet( nbet ), bs( nmax*nmax ),
425 $ c( nmax, nmax ), cc( nmax*nmax ),
426 $ cs( nmax*nmax ), ct( nmax ), g( nmax )
427 INTEGER IDIM( NIDIM )
428* .. Local Scalars ..
429 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
430 INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
431 $ lbb, lcc, lda, ldas, ldb, ldbs, ldc, ldcs, m,
432 $ ma, mb, ms, n, na, nargs, nb, nc, ns
433 LOGICAL NULL, RESET, SAME, TRANA, TRANB
434 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
435 CHARACTER*3 ICH
436* .. Local Arrays ..
437 LOGICAL ISAME( 13 )
438* .. External Functions ..
439 LOGICAL LDE, LDERES
440 EXTERNAL LDE, LDERES
441* .. External Subroutines ..
442 EXTERNAL dgemm, dmake, dmmch
443* .. Intrinsic Functions ..
444 INTRINSIC max
445* .. Scalars in Common ..
446 INTEGER INFOT, NOUTC
447 LOGICAL LERR, OK
448* .. Common blocks ..
449 COMMON /infoc/infot, noutc, ok, lerr
450* .. Data statements ..
451 DATA ich/'NTC'/
452* .. Executable Statements ..
453*
454 nargs = 13
455 nc = 0
456 reset = .true.
457 errmax = zero
458*
459 DO 110 im = 1, nidim
460 m = idim( im )
461*
462 DO 100 in = 1, nidim
463 n = idim( in )
464* Set LDC to 1 more than minimum value if room.
465 ldc = m
466 IF( ldc.LT.nmax )
467 $ ldc = ldc + 1
468* Skip tests if not enough room.
469 IF( ldc.GT.nmax )
470 $ GO TO 100
471 lcc = ldc*n
472 null = n.LE.0.OR.m.LE.0
473*
474 DO 90 ik = 1, nidim
475 k = idim( ik )
476*
477 DO 80 ica = 1, 3
478 transa = ich( ica: ica )
479 trana = transa.EQ.'T'.OR.transa.EQ.'C'
480*
481 IF( trana )THEN
482 ma = k
483 na = m
484 ELSE
485 ma = m
486 na = k
487 END IF
488* Set LDA to 1 more than minimum value if room.
489 lda = ma
490 IF( lda.LT.nmax )
491 $ lda = lda + 1
492* Skip tests if not enough room.
493 IF( lda.GT.nmax )
494 $ GO TO 80
495 laa = lda*na
496*
497* Generate the matrix A.
498*
499 CALL dmake( 'GE', ' ', ' ', ma, na, a, nmax, aa, lda,
500 $ reset, zero )
501*
502 DO 70 icb = 1, 3
503 transb = ich( icb: icb )
504 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
505*
506 IF( tranb )THEN
507 mb = n
508 nb = k
509 ELSE
510 mb = k
511 nb = n
512 END IF
513* Set LDB to 1 more than minimum value if room.
514 ldb = mb
515 IF( ldb.LT.nmax )
516 $ ldb = ldb + 1
517* Skip tests if not enough room.
518 IF( ldb.GT.nmax )
519 $ GO TO 70
520 lbb = ldb*nb
521*
522* Generate the matrix B.
523*
524 CALL dmake( 'GE', ' ', ' ', mb, nb, b, nmax, bb,
525 $ ldb, reset, zero )
526*
527 DO 60 ia = 1, nalf
528 alpha = alf( ia )
529*
530 DO 50 ib = 1, nbet
531 beta = bet( ib )
532*
533* Generate the matrix C.
534*
535 CALL dmake( 'GE', ' ', ' ', m, n, c, nmax,
536 $ cc, ldc, reset, zero )
537*
538 nc = nc + 1
539*
540* Save every datum before calling the
541* subroutine.
542*
543 tranas = transa
544 tranbs = transb
545 ms = m
546 ns = n
547 ks = k
548 als = alpha
549 DO 10 i = 1, laa
550 as( i ) = aa( i )
551 10 CONTINUE
552 ldas = lda
553 DO 20 i = 1, lbb
554 bs( i ) = bb( i )
555 20 CONTINUE
556 ldbs = ldb
557 bls = beta
558 DO 30 i = 1, lcc
559 cs( i ) = cc( i )
560 30 CONTINUE
561 ldcs = ldc
562*
563* Call the subroutine.
564*
565 IF( trace )
566 $ WRITE( ntra, fmt = 9995 )nc, sname,
567 $ transa, transb, m, n, k, alpha, lda, ldb,
568 $ beta, ldc
569 IF( rewi )
570 $ rewind ntra
571 CALL dgemm( transa, transb, m, n, k, alpha,
572 $ aa, lda, bb, ldb, beta, cc, ldc )
573*
574* Check if error-exit was taken incorrectly.
575*
576 IF( .NOT.ok )THEN
577 WRITE( nout, fmt = 9994 )
578 fatal = .true.
579 GO TO 120
580 END IF
581*
582* See what data changed inside subroutines.
583*
584 isame( 1 ) = transa.EQ.tranas
585 isame( 2 ) = transb.EQ.tranbs
586 isame( 3 ) = ms.EQ.m
587 isame( 4 ) = ns.EQ.n
588 isame( 5 ) = ks.EQ.k
589 isame( 6 ) = als.EQ.alpha
590 isame( 7 ) = lde( as, aa, laa )
591 isame( 8 ) = ldas.EQ.lda
592 isame( 9 ) = lde( bs, bb, lbb )
593 isame( 10 ) = ldbs.EQ.ldb
594 isame( 11 ) = bls.EQ.beta
595 IF( null )THEN
596 isame( 12 ) = lde( cs, cc, lcc )
597 ELSE
598 isame( 12 ) = lderes( 'GE', ' ', m, n, cs,
599 $ cc, ldc )
600 END IF
601 isame( 13 ) = ldcs.EQ.ldc
602*
603* If data was incorrectly changed, report
604* and return.
605*
606 same = .true.
607 DO 40 i = 1, nargs
608 same = same.AND.isame( i )
609 IF( .NOT.isame( i ) )
610 $ WRITE( nout, fmt = 9998 )i
611 40 CONTINUE
612 IF( .NOT.same )THEN
613 fatal = .true.
614 GO TO 120
615 END IF
616*
617 IF( .NOT.null )THEN
618*
619* Check the result.
620*
621 CALL dmmch( transa, transb, m, n, k,
622 $ alpha, a, nmax, b, nmax, beta,
623 $ c, nmax, ct, g, cc, ldc, eps,
624 $ err, fatal, nout, .true. )
625 errmax = max( errmax, err )
626* If got really bad answer, report and
627* return.
628 IF( fatal )
629 $ GO TO 120
630 END IF
631*
632 50 CONTINUE
633*
634 60 CONTINUE
635*
636 70 CONTINUE
637*
638 80 CONTINUE
639*
640 90 CONTINUE
641*
642 100 CONTINUE
643*
644 110 CONTINUE
645*
646* Report result.
647*
648 IF( errmax.LT.thresh )THEN
649 WRITE( nout, fmt = 9999 )sname, nc
650 ELSE
651 WRITE( nout, fmt = 9997 )sname, nc, errmax
652 END IF
653 GO TO 130
654*
655 120 CONTINUE
656 WRITE( nout, fmt = 9996 )sname
657 WRITE( nout, fmt = 9995 )nc, sname, transa, transb, m, n, k,
658 $ alpha, lda, ldb, beta, ldc
659*
660 130 CONTINUE
661 RETURN
662*
663 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
664 $ 'S)' )
665 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
666 $ 'ANGED INCORRECTLY *******' )
667 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
668 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
669 $ ' - SUSPECT *******' )
670 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
671 9995 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',''', a1, ''',',
672 $ 3( i3, ',' ), f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', ',
673 $ 'C,', i3, ').' )
674 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
675 $ '******' )
676*
677* End of DCHK1
678*
679 END
680 SUBROUTINE dchk2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
681 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
682 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
683*
684* Tests DSYMM.
685*
686* Auxiliary routine for test program for Level 3 Blas.
687*
688* -- Written on 8-February-1989.
689* Jack Dongarra, Argonne National Laboratory.
690* Iain Duff, AERE Harwell.
691* Jeremy Du Croz, Numerical Algorithms Group Ltd.
692* Sven Hammarling, Numerical Algorithms Group Ltd.
693*
694* .. Parameters ..
695 DOUBLE PRECISION ZERO
696 PARAMETER ( ZERO = 0.0d0 )
697* .. Scalar Arguments ..
698 DOUBLE PRECISION EPS, THRESH
699 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
700 LOGICAL FATAL, REWI, TRACE
701 CHARACTER*7 SNAME
702* .. Array Arguments ..
703 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
704 $ as( nmax*nmax ), b( nmax, nmax ),
705 $ bb( nmax*nmax ), bet( nbet ), bs( nmax*nmax ),
706 $ c( nmax, nmax ), cc( nmax*nmax ),
707 $ cs( nmax*nmax ), ct( nmax ), g( nmax )
708 INTEGER IDIM( NIDIM )
709* .. Local Scalars ..
710 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
711 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
712 $ lda, ldas, ldb, ldbs, ldc, ldcs, m, ms, n, na,
713 $ nargs, nc, ns
714 LOGICAL LEFT, NULL, RESET, SAME
715 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
716 CHARACTER*2 ICHS, ICHU
717* .. Local Arrays ..
718 LOGICAL ISAME( 13 )
719* .. External Functions ..
720 LOGICAL LDE, LDERES
721 EXTERNAL LDE, LDERES
722* .. External Subroutines ..
723 EXTERNAL dmake, dmmch, dsymm
724* .. Intrinsic Functions ..
725 INTRINSIC max
726* .. Scalars in Common ..
727 INTEGER INFOT, NOUTC
728 LOGICAL LERR, OK
729* .. Common blocks ..
730 COMMON /infoc/infot, noutc, ok, lerr
731* .. Data statements ..
732 DATA ichs/'LR'/, ichu/'UL'/
733* .. Executable Statements ..
734*
735 nargs = 12
736 nc = 0
737 reset = .true.
738 errmax = zero
739*
740 DO 100 im = 1, nidim
741 m = idim( im )
742*
743 DO 90 in = 1, nidim
744 n = idim( in )
745* Set LDC to 1 more than minimum value if room.
746 ldc = m
747 IF( ldc.LT.nmax )
748 $ ldc = ldc + 1
749* Skip tests if not enough room.
750 IF( ldc.GT.nmax )
751 $ GO TO 90
752 lcc = ldc*n
753 null = n.LE.0.OR.m.LE.0
754*
755* Set LDB to 1 more than minimum value if room.
756 ldb = m
757 IF( ldb.LT.nmax )
758 $ ldb = ldb + 1
759* Skip tests if not enough room.
760 IF( ldb.GT.nmax )
761 $ GO TO 90
762 lbb = ldb*n
763*
764* Generate the matrix B.
765*
766 CALL dmake( 'GE', ' ', ' ', m, n, b, nmax, bb, ldb, reset,
767 $ zero )
768*
769 DO 80 ics = 1, 2
770 side = ichs( ics: ics )
771 left = side.EQ.'L'
772*
773 IF( left )THEN
774 na = m
775 ELSE
776 na = n
777 END IF
778* Set LDA to 1 more than minimum value if room.
779 lda = na
780 IF( lda.LT.nmax )
781 $ lda = lda + 1
782* Skip tests if not enough room.
783 IF( lda.GT.nmax )
784 $ GO TO 80
785 laa = lda*na
786*
787 DO 70 icu = 1, 2
788 uplo = ichu( icu: icu )
789*
790* Generate the symmetric matrix A.
791*
792 CALL dmake( 'SY', uplo, ' ', na, na, a, nmax, aa, lda,
793 $ reset, zero )
794*
795 DO 60 ia = 1, nalf
796 alpha = alf( ia )
797*
798 DO 50 ib = 1, nbet
799 beta = bet( ib )
800*
801* Generate the matrix C.
802*
803 CALL dmake( 'GE', ' ', ' ', m, n, c, nmax, cc,
804 $ ldc, reset, zero )
805*
806 nc = nc + 1
807*
808* Save every datum before calling the
809* subroutine.
810*
811 sides = side
812 uplos = uplo
813 ms = m
814 ns = n
815 als = alpha
816 DO 10 i = 1, laa
817 as( i ) = aa( i )
818 10 CONTINUE
819 ldas = lda
820 DO 20 i = 1, lbb
821 bs( i ) = bb( i )
822 20 CONTINUE
823 ldbs = ldb
824 bls = beta
825 DO 30 i = 1, lcc
826 cs( i ) = cc( i )
827 30 CONTINUE
828 ldcs = ldc
829*
830* Call the subroutine.
831*
832 IF( trace )
833 $ WRITE( ntra, fmt = 9995 )nc, sname, side,
834 $ uplo, m, n, alpha, lda, ldb, beta, ldc
835 IF( rewi )
836 $ rewind ntra
837 CALL dsymm( side, uplo, m, n, alpha, aa, lda,
838 $ bb, ldb, beta, cc, ldc )
839*
840* Check if error-exit was taken incorrectly.
841*
842 IF( .NOT.ok )THEN
843 WRITE( nout, fmt = 9994 )
844 fatal = .true.
845 GO TO 110
846 END IF
847*
848* See what data changed inside subroutines.
849*
850 isame( 1 ) = sides.EQ.side
851 isame( 2 ) = uplos.EQ.uplo
852 isame( 3 ) = ms.EQ.m
853 isame( 4 ) = ns.EQ.n
854 isame( 5 ) = als.EQ.alpha
855 isame( 6 ) = lde( as, aa, laa )
856 isame( 7 ) = ldas.EQ.lda
857 isame( 8 ) = lde( bs, bb, lbb )
858 isame( 9 ) = ldbs.EQ.ldb
859 isame( 10 ) = bls.EQ.beta
860 IF( null )THEN
861 isame( 11 ) = lde( cs, cc, lcc )
862 ELSE
863 isame( 11 ) = lderes( 'GE', ' ', m, n, cs,
864 $ cc, ldc )
865 END IF
866 isame( 12 ) = ldcs.EQ.ldc
867*
868* If data was incorrectly changed, report and
869* return.
870*
871 same = .true.
872 DO 40 i = 1, nargs
873 same = same.AND.isame( i )
874 IF( .NOT.isame( i ) )
875 $ WRITE( nout, fmt = 9998 )i
876 40 CONTINUE
877 IF( .NOT.same )THEN
878 fatal = .true.
879 GO TO 110
880 END IF
881*
882 IF( .NOT.null )THEN
883*
884* Check the result.
885*
886 IF( left )THEN
887 CALL dmmch( 'N', 'N', m, n, m, alpha, a,
888 $ nmax, b, nmax, beta, c, nmax,
889 $ ct, g, cc, ldc, eps, err,
890 $ fatal, nout, .true. )
891 ELSE
892 CALL dmmch( 'N', 'N', m, n, n, alpha, b,
893 $ nmax, a, nmax, beta, c, nmax,
894 $ ct, g, cc, ldc, eps, err,
895 $ fatal, nout, .true. )
896 END IF
897 errmax = max( errmax, err )
898* If got really bad answer, report and
899* return.
900 IF( fatal )
901 $ GO TO 110
902 END IF
903*
904 50 CONTINUE
905*
906 60 CONTINUE
907*
908 70 CONTINUE
909*
910 80 CONTINUE
911*
912 90 CONTINUE
913*
914 100 CONTINUE
915*
916* Report result.
917*
918 IF( errmax.LT.thresh )THEN
919 WRITE( nout, fmt = 9999 )sname, nc
920 ELSE
921 WRITE( nout, fmt = 9997 )sname, nc, errmax
922 END IF
923 GO TO 120
924*
925 110 CONTINUE
926 WRITE( nout, fmt = 9996 )sname
927 WRITE( nout, fmt = 9995 )nc, sname, side, uplo, m, n, alpha, lda,
928 $ ldb, beta, ldc
929*
930 120 CONTINUE
931 RETURN
932*
933 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
934 $ 'S)' )
935 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
936 $ 'ANGED INCORRECTLY *******' )
937 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
938 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
939 $ ' - SUSPECT *******' )
940 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
941 9995 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
942 $ f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', C,', i3, ') ',
943 $ ' .' )
944 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
945 $ '******' )
946*
947* End of DCHK2
948*
949 END
950 SUBROUTINE dchk3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
951 $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS,
952 $ B, BB, BS, CT, G, C )
953*
954* Tests DTRMM and DTRSM.
955*
956* Auxiliary routine for test program for Level 3 Blas.
957*
958* -- Written on 8-February-1989.
959* Jack Dongarra, Argonne National Laboratory.
960* Iain Duff, AERE Harwell.
961* Jeremy Du Croz, Numerical Algorithms Group Ltd.
962* Sven Hammarling, Numerical Algorithms Group Ltd.
963*
964* .. Parameters ..
965 DOUBLE PRECISION ZERO, ONE
966 PARAMETER ( ZERO = 0.0d0, one = 1.0d0 )
967* .. Scalar Arguments ..
968 DOUBLE PRECISION EPS, THRESH
969 INTEGER NALF, NIDIM, NMAX, NOUT, NTRA
970 LOGICAL FATAL, REWI, TRACE
971 CHARACTER*7 SNAME
972* .. Array Arguments ..
973 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
974 $ as( nmax*nmax ), b( nmax, nmax ),
975 $ bb( nmax*nmax ), bs( nmax*nmax ),
976 $ c( nmax, nmax ), ct( nmax ), g( nmax )
977 INTEGER IDIM( NIDIM )
978* .. Local Scalars ..
979 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX
980 INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
981 $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
982 $ NS
983 LOGICAL LEFT, NULL, RESET, SAME
984 CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
985 $ uplos
986 CHARACTER*2 ICHD, ICHS, ICHU
987 CHARACTER*3 ICHT
988* .. Local Arrays ..
989 LOGICAL ISAME( 13 )
990* .. External Functions ..
991 LOGICAL LDE, LDERES
992 EXTERNAL lde, lderes
993* .. External Subroutines ..
994 EXTERNAL dmake, dmmch, dtrmm, dtrsm
995* .. Intrinsic Functions ..
996 INTRINSIC max
997* .. Scalars in Common ..
998 INTEGER INFOT, NOUTC
999 LOGICAL LERR, OK
1000* .. Common blocks ..
1001 COMMON /infoc/infot, noutc, ok, lerr
1002* .. Data statements ..
1003 DATA ichu/'UL'/, icht/'NTC'/, ichd/'UN'/, ichs/'LR'/
1004* .. Executable Statements ..
1005*
1006 nargs = 11
1007 nc = 0
1008 reset = .true.
1009 errmax = zero
1010* Set up zero matrix for DMMCH.
1011 DO 20 j = 1, nmax
1012 DO 10 i = 1, nmax
1013 c( i, j ) = zero
1014 10 CONTINUE
1015 20 CONTINUE
1016*
1017 DO 140 im = 1, nidim
1018 m = idim( im )
1019*
1020 DO 130 in = 1, nidim
1021 n = idim( in )
1022* Set LDB to 1 more than minimum value if room.
1023 ldb = m
1024 IF( ldb.LT.nmax )
1025 $ ldb = ldb + 1
1026* Skip tests if not enough room.
1027 IF( ldb.GT.nmax )
1028 $ GO TO 130
1029 lbb = ldb*n
1030 null = m.LE.0.OR.n.LE.0
1031*
1032 DO 120 ics = 1, 2
1033 side = ichs( ics: ics )
1034 left = side.EQ.'L'
1035 IF( left )THEN
1036 na = m
1037 ELSE
1038 na = n
1039 END IF
1040* Set LDA to 1 more than minimum value if room.
1041 lda = na
1042 IF( lda.LT.nmax )
1043 $ lda = lda + 1
1044* Skip tests if not enough room.
1045 IF( lda.GT.nmax )
1046 $ GO TO 130
1047 laa = lda*na
1048*
1049 DO 110 icu = 1, 2
1050 uplo = ichu( icu: icu )
1051*
1052 DO 100 ict = 1, 3
1053 transa = icht( ict: ict )
1054*
1055 DO 90 icd = 1, 2
1056 diag = ichd( icd: icd )
1057*
1058 DO 80 ia = 1, nalf
1059 alpha = alf( ia )
1060*
1061* Generate the matrix A.
1062*
1063 CALL dmake( 'TR', uplo, diag, na, na, a,
1064 $ nmax, aa, lda, reset, zero )
1065*
1066* Generate the matrix B.
1067*
1068 CALL dmake( 'GE', ' ', ' ', m, n, b, nmax,
1069 $ bb, ldb, reset, zero )
1070*
1071 nc = nc + 1
1072*
1073* Save every datum before calling the
1074* subroutine.
1075*
1076 sides = side
1077 uplos = uplo
1078 tranas = transa
1079 diags = diag
1080 ms = m
1081 ns = n
1082 als = alpha
1083 DO 30 i = 1, laa
1084 as( i ) = aa( i )
1085 30 CONTINUE
1086 ldas = lda
1087 DO 40 i = 1, lbb
1088 bs( i ) = bb( i )
1089 40 CONTINUE
1090 ldbs = ldb
1091*
1092* Call the subroutine.
1093*
1094 IF( sname( 4: 5 ).EQ.'MM' )THEN
1095 IF( trace )
1096 $ WRITE( ntra, fmt = 9995 )nc, sname,
1097 $ side, uplo, transa, diag, m, n, alpha,
1098 $ lda, ldb
1099 IF( rewi )
1100 $ rewind ntra
1101 CALL dtrmm( side, uplo, transa, diag, m,
1102 $ n, alpha, aa, lda, bb, ldb )
1103 ELSE IF( sname( 4: 5 ).EQ.'SM' )THEN
1104 IF( trace )
1105 $ WRITE( ntra, fmt = 9995 )nc, sname,
1106 $ side, uplo, transa, diag, m, n, alpha,
1107 $ lda, ldb
1108 IF( rewi )
1109 $ rewind ntra
1110 CALL dtrsm( side, uplo, transa, diag, m,
1111 $ n, alpha, aa, lda, bb, ldb )
1112 END IF
1113*
1114* Check if error-exit was taken incorrectly.
1115*
1116 IF( .NOT.ok )THEN
1117 WRITE( nout, fmt = 9994 )
1118 fatal = .true.
1119 GO TO 150
1120 END IF
1121*
1122* See what data changed inside subroutines.
1123*
1124 isame( 1 ) = sides.EQ.side
1125 isame( 2 ) = uplos.EQ.uplo
1126 isame( 3 ) = tranas.EQ.transa
1127 isame( 4 ) = diags.EQ.diag
1128 isame( 5 ) = ms.EQ.m
1129 isame( 6 ) = ns.EQ.n
1130 isame( 7 ) = als.EQ.alpha
1131 isame( 8 ) = lde( as, aa, laa )
1132 isame( 9 ) = ldas.EQ.lda
1133 IF( null )THEN
1134 isame( 10 ) = lde( bs, bb, lbb )
1135 ELSE
1136 isame( 10 ) = lderes( 'GE', ' ', m, n, bs,
1137 $ bb, ldb )
1138 END IF
1139 isame( 11 ) = ldbs.EQ.ldb
1140*
1141* If data was incorrectly changed, report and
1142* return.
1143*
1144 same = .true.
1145 DO 50 i = 1, nargs
1146 same = same.AND.isame( i )
1147 IF( .NOT.isame( i ) )
1148 $ WRITE( nout, fmt = 9998 )i
1149 50 CONTINUE
1150 IF( .NOT.same )THEN
1151 fatal = .true.
1152 GO TO 150
1153 END IF
1154*
1155 IF( .NOT.null )THEN
1156 IF( sname( 4: 5 ).EQ.'MM' )THEN
1157*
1158* Check the result.
1159*
1160 IF( left )THEN
1161 CALL dmmch( transa, 'N', m, n, m,
1162 $ alpha, a, nmax, b, nmax,
1163 $ zero, c, nmax, ct, g,
1164 $ bb, ldb, eps, err,
1165 $ fatal, nout, .true. )
1166 ELSE
1167 CALL dmmch( 'N', transa, m, n, n,
1168 $ alpha, b, nmax, a, nmax,
1169 $ zero, c, nmax, ct, g,
1170 $ bb, ldb, eps, err,
1171 $ fatal, nout, .true. )
1172 END IF
1173 ELSE IF( sname( 4: 5 ).EQ.'SM' )THEN
1174*
1175* Compute approximation to original
1176* matrix.
1177*
1178 DO 70 j = 1, n
1179 DO 60 i = 1, m
1180 c( i, j ) = bb( i + ( j - 1 )*
1181 $ ldb )
1182 bb( i + ( j - 1 )*ldb ) = alpha*
1183 $ b( i, j )
1184 60 CONTINUE
1185 70 CONTINUE
1186*
1187 IF( left )THEN
1188 CALL dmmch( transa, 'N', m, n, m,
1189 $ one, a, nmax, c, nmax,
1190 $ zero, b, nmax, ct, g,
1191 $ bb, ldb, eps, err,
1192 $ fatal, nout, .false. )
1193 ELSE
1194 CALL dmmch( 'N', transa, m, n, n,
1195 $ one, c, nmax, a, nmax,
1196 $ zero, b, nmax, ct, g,
1197 $ bb, ldb, eps, err,
1198 $ fatal, nout, .false. )
1199 END IF
1200 END IF
1201 errmax = max( errmax, err )
1202* If got really bad answer, report and
1203* return.
1204 IF( fatal )
1205 $ GO TO 150
1206 END IF
1207*
1208 80 CONTINUE
1209*
1210 90 CONTINUE
1211*
1212 100 CONTINUE
1213*
1214 110 CONTINUE
1215*
1216 120 CONTINUE
1217*
1218 130 CONTINUE
1219*
1220 140 CONTINUE
1221*
1222* Report result.
1223*
1224 IF( errmax.LT.thresh )THEN
1225 WRITE( nout, fmt = 9999 )sname, nc
1226 ELSE
1227 WRITE( nout, fmt = 9997 )sname, nc, errmax
1228 END IF
1229 GO TO 160
1230*
1231 150 CONTINUE
1232 WRITE( nout, fmt = 9996 )sname
1233 WRITE( nout, fmt = 9995 )nc, sname, side, uplo, transa, diag, m,
1234 $ n, alpha, lda, ldb
1235*
1236 160 CONTINUE
1237 RETURN
1238*
1239 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1240 $ 'S)' )
1241 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1242 $ 'ANGED INCORRECTLY *******' )
1243 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1244 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1245 $ ' - SUSPECT *******' )
1246 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1247 9995 FORMAT( 1x, i6, ': ', a6, '(', 4( '''', a1, ''',' ), 2( i3, ',' ),
1248 $ f4.1, ', A,', i3, ', B,', i3, ') .' )
1249 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1250 $ '******' )
1251*
1252* End of DCHK3
1253*
1254 END
1255 SUBROUTINE dchk4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1256 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1257 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
1258*
1259* Tests DSYRK.
1260*
1261* Auxiliary routine for test program for Level 3 Blas.
1262*
1263* -- Written on 8-February-1989.
1264* Jack Dongarra, Argonne National Laboratory.
1265* Iain Duff, AERE Harwell.
1266* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1267* Sven Hammarling, Numerical Algorithms Group Ltd.
1268*
1269* .. Parameters ..
1270 DOUBLE PRECISION ZERO
1271 PARAMETER ( ZERO = 0.0d0 )
1272* .. Scalar Arguments ..
1273 DOUBLE PRECISION EPS, THRESH
1274 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1275 LOGICAL FATAL, REWI, TRACE
1276 CHARACTER*7 SNAME
1277* .. Array Arguments ..
1278 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1279 $ as( nmax*nmax ), b( nmax, nmax ),
1280 $ bb( nmax*nmax ), bet( nbet ), bs( nmax*nmax ),
1281 $ c( nmax, nmax ), cc( nmax*nmax ),
1282 $ cs( nmax*nmax ), ct( nmax ), g( nmax )
1283 INTEGER IDIM( NIDIM )
1284* .. Local Scalars ..
1285 DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1286 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1287 $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1288 $ NARGS, NC, NS
1289 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1290 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1291 CHARACTER*2 ICHU
1292 CHARACTER*3 ICHT
1293* .. Local Arrays ..
1294 LOGICAL ISAME( 13 )
1295* .. External Functions ..
1296 LOGICAL LDE, LDERES
1297 EXTERNAL lde, lderes
1298* .. External Subroutines ..
1299 EXTERNAL dmake, dmmch, dsyrk
1300* .. Intrinsic Functions ..
1301 INTRINSIC max
1302* .. Scalars in Common ..
1303 INTEGER INFOT, NOUTC
1304 LOGICAL LERR, OK
1305* .. Common blocks ..
1306 COMMON /infoc/infot, noutc, ok, lerr
1307* .. Data statements ..
1308 DATA icht/'NTC'/, ichu/'UL'/
1309* .. Executable Statements ..
1310*
1311 nargs = 10
1312 nc = 0
1313 reset = .true.
1314 errmax = zero
1315*
1316 DO 100 in = 1, nidim
1317 n = idim( in )
1318* Set LDC to 1 more than minimum value if room.
1319 ldc = n
1320 IF( ldc.LT.nmax )
1321 $ ldc = ldc + 1
1322* Skip tests if not enough room.
1323 IF( ldc.GT.nmax )
1324 $ GO TO 100
1325 lcc = ldc*n
1326 null = n.LE.0
1327*
1328 DO 90 ik = 1, nidim
1329 k = idim( ik )
1330*
1331 DO 80 ict = 1, 3
1332 trans = icht( ict: ict )
1333 tran = trans.EQ.'T'.OR.trans.EQ.'C'
1334 IF( tran )THEN
1335 ma = k
1336 na = n
1337 ELSE
1338 ma = n
1339 na = k
1340 END IF
1341* Set LDA to 1 more than minimum value if room.
1342 lda = ma
1343 IF( lda.LT.nmax )
1344 $ lda = lda + 1
1345* Skip tests if not enough room.
1346 IF( lda.GT.nmax )
1347 $ GO TO 80
1348 laa = lda*na
1349*
1350* Generate the matrix A.
1351*
1352 CALL dmake( 'GE', ' ', ' ', ma, na, a, nmax, aa, lda,
1353 $ reset, zero )
1354*
1355 DO 70 icu = 1, 2
1356 uplo = ichu( icu: icu )
1357 upper = uplo.EQ.'U'
1358*
1359 DO 60 ia = 1, nalf
1360 alpha = alf( ia )
1361*
1362 DO 50 ib = 1, nbet
1363 beta = bet( ib )
1364*
1365* Generate the matrix C.
1366*
1367 CALL dmake( 'SY', uplo, ' ', n, n, c, nmax, cc,
1368 $ ldc, reset, zero )
1369*
1370 nc = nc + 1
1371*
1372* Save every datum before calling the subroutine.
1373*
1374 uplos = uplo
1375 transs = trans
1376 ns = n
1377 ks = k
1378 als = alpha
1379 DO 10 i = 1, laa
1380 as( i ) = aa( i )
1381 10 CONTINUE
1382 ldas = lda
1383 bets = beta
1384 DO 20 i = 1, lcc
1385 cs( i ) = cc( i )
1386 20 CONTINUE
1387 ldcs = ldc
1388*
1389* Call the subroutine.
1390*
1391 IF( trace )
1392 $ WRITE( ntra, fmt = 9994 )nc, sname, uplo,
1393 $ trans, n, k, alpha, lda, beta, ldc
1394 IF( rewi )
1395 $ rewind ntra
1396 CALL dsyrk( uplo, trans, n, k, alpha, aa, lda,
1397 $ beta, cc, ldc )
1398*
1399* Check if error-exit was taken incorrectly.
1400*
1401 IF( .NOT.ok )THEN
1402 WRITE( nout, fmt = 9993 )
1403 fatal = .true.
1404 GO TO 120
1405 END IF
1406*
1407* See what data changed inside subroutines.
1408*
1409 isame( 1 ) = uplos.EQ.uplo
1410 isame( 2 ) = transs.EQ.trans
1411 isame( 3 ) = ns.EQ.n
1412 isame( 4 ) = ks.EQ.k
1413 isame( 5 ) = als.EQ.alpha
1414 isame( 6 ) = lde( as, aa, laa )
1415 isame( 7 ) = ldas.EQ.lda
1416 isame( 8 ) = bets.EQ.beta
1417 IF( null )THEN
1418 isame( 9 ) = lde( cs, cc, lcc )
1419 ELSE
1420 isame( 9 ) = lderes( 'SY', uplo, n, n, cs,
1421 $ cc, ldc )
1422 END IF
1423 isame( 10 ) = ldcs.EQ.ldc
1424*
1425* If data was incorrectly changed, report and
1426* return.
1427*
1428 same = .true.
1429 DO 30 i = 1, nargs
1430 same = same.AND.isame( i )
1431 IF( .NOT.isame( i ) )
1432 $ WRITE( nout, fmt = 9998 )i
1433 30 CONTINUE
1434 IF( .NOT.same )THEN
1435 fatal = .true.
1436 GO TO 120
1437 END IF
1438*
1439 IF( .NOT.null )THEN
1440*
1441* Check the result column by column.
1442*
1443 jc = 1
1444 DO 40 j = 1, n
1445 IF( upper )THEN
1446 jj = 1
1447 lj = j
1448 ELSE
1449 jj = j
1450 lj = n - j + 1
1451 END IF
1452 IF( tran )THEN
1453 CALL dmmch( 'T', 'N', lj, 1, k, alpha,
1454 $ a( 1, jj ), nmax,
1455 $ a( 1, j ), nmax, beta,
1456 $ c( jj, j ), nmax, ct, g,
1457 $ cc( jc ), ldc, eps, err,
1458 $ fatal, nout, .true. )
1459 ELSE
1460 CALL dmmch( 'N', 'T', lj, 1, k, alpha,
1461 $ a( jj, 1 ), nmax,
1462 $ a( j, 1 ), nmax, beta,
1463 $ c( jj, j ), nmax, ct, g,
1464 $ cc( jc ), ldc, eps, err,
1465 $ fatal, nout, .true. )
1466 END IF
1467 IF( upper )THEN
1468 jc = jc + ldc
1469 ELSE
1470 jc = jc + ldc + 1
1471 END IF
1472 errmax = max( errmax, err )
1473* If got really bad answer, report and
1474* return.
1475 IF( fatal )
1476 $ GO TO 110
1477 40 CONTINUE
1478 END IF
1479*
1480 50 CONTINUE
1481*
1482 60 CONTINUE
1483*
1484 70 CONTINUE
1485*
1486 80 CONTINUE
1487*
1488 90 CONTINUE
1489*
1490 100 CONTINUE
1491*
1492* Report result.
1493*
1494 IF( errmax.LT.thresh )THEN
1495 WRITE( nout, fmt = 9999 )sname, nc
1496 ELSE
1497 WRITE( nout, fmt = 9997 )sname, nc, errmax
1498 END IF
1499 GO TO 130
1500*
1501 110 CONTINUE
1502 IF( n.GT.1 )
1503 $ WRITE( nout, fmt = 9995 )j
1504*
1505 120 CONTINUE
1506 WRITE( nout, fmt = 9996 )sname
1507 WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, n, k, alpha,
1508 $ lda, beta, ldc
1509*
1510 130 CONTINUE
1511 RETURN
1512*
1513 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1514 $ 'S)' )
1515 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1516 $ 'ANGED INCORRECTLY *******' )
1517 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1518 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1519 $ ' - SUSPECT *******' )
1520 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1521 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1522 9994 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1523 $ f4.1, ', A,', i3, ',', f4.1, ', C,', i3, ') .' )
1524 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1525 $ '******' )
1526*
1527* End of DCHK4
1528*
1529 END
1530 SUBROUTINE dchk5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1531 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1532 $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
1533*
1534* Tests DSYR2K.
1535*
1536* Auxiliary routine for test program for Level 3 Blas.
1537*
1538* -- Written on 8-February-1989.
1539* Jack Dongarra, Argonne National Laboratory.
1540* Iain Duff, AERE Harwell.
1541* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1542* Sven Hammarling, Numerical Algorithms Group Ltd.
1543*
1544* .. Parameters ..
1545 DOUBLE PRECISION ZERO
1546 PARAMETER ( ZERO = 0.0d0 )
1547* .. Scalar Arguments ..
1548 DOUBLE PRECISION EPS, THRESH
1549 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1550 LOGICAL FATAL, REWI, TRACE
1551 CHARACTER*7 SNAME
1552* .. Array Arguments ..
1553 DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1554 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1555 $ bet( nbet ), bs( nmax*nmax ), c( nmax, nmax ),
1556 $ cc( nmax*nmax ), cs( nmax*nmax ), ct( nmax ),
1557 $ g( nmax ), w( 2*nmax )
1558 INTEGER IDIM( NIDIM )
1559* .. Local Scalars ..
1560 DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1561 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1562 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1563 $ ldc, ldcs, lj, ma, n, na, nargs, nc, ns
1564 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1565 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1566 CHARACTER*2 ICHU
1567 CHARACTER*3 ICHT
1568* .. Local Arrays ..
1569 LOGICAL ISAME( 13 )
1570* .. External Functions ..
1571 LOGICAL LDE, LDERES
1572 EXTERNAL LDE, LDERES
1573* .. External Subroutines ..
1574 EXTERNAL dmake, dmmch, dsyr2k
1575* .. Intrinsic Functions ..
1576 INTRINSIC max
1577* .. Scalars in Common ..
1578 INTEGER INFOT, NOUTC
1579 LOGICAL LERR, OK
1580* .. Common blocks ..
1581 COMMON /infoc/infot, noutc, ok, lerr
1582* .. Data statements ..
1583 DATA icht/'NTC'/, ichu/'UL'/
1584* .. Executable Statements ..
1585*
1586 nargs = 12
1587 nc = 0
1588 reset = .true.
1589 errmax = zero
1590*
1591 DO 130 in = 1, nidim
1592 n = idim( in )
1593* Set LDC to 1 more than minimum value if room.
1594 ldc = n
1595 IF( ldc.LT.nmax )
1596 $ ldc = ldc + 1
1597* Skip tests if not enough room.
1598 IF( ldc.GT.nmax )
1599 $ GO TO 130
1600 lcc = ldc*n
1601 null = n.LE.0
1602*
1603 DO 120 ik = 1, nidim
1604 k = idim( ik )
1605*
1606 DO 110 ict = 1, 3
1607 trans = icht( ict: ict )
1608 tran = trans.EQ.'T'.OR.trans.EQ.'C'
1609 IF( tran )THEN
1610 ma = k
1611 na = n
1612 ELSE
1613 ma = n
1614 na = k
1615 END IF
1616* Set LDA to 1 more than minimum value if room.
1617 lda = ma
1618 IF( lda.LT.nmax )
1619 $ lda = lda + 1
1620* Skip tests if not enough room.
1621 IF( lda.GT.nmax )
1622 $ GO TO 110
1623 laa = lda*na
1624*
1625* Generate the matrix A.
1626*
1627 IF( tran )THEN
1628 CALL dmake( 'GE', ' ', ' ', ma, na, ab, 2*nmax, aa,
1629 $ lda, reset, zero )
1630 ELSE
1631 CALL dmake( 'GE', ' ', ' ', ma, na, ab, nmax, aa, lda,
1632 $ reset, zero )
1633 END IF
1634*
1635* Generate the matrix B.
1636*
1637 ldb = lda
1638 lbb = laa
1639 IF( tran )THEN
1640 CALL dmake( 'GE', ' ', ' ', ma, na, ab( k + 1 ),
1641 $ 2*nmax, bb, ldb, reset, zero )
1642 ELSE
1643 CALL dmake( 'GE', ' ', ' ', ma, na, ab( k*nmax + 1 ),
1644 $ nmax, bb, ldb, reset, zero )
1645 END IF
1646*
1647 DO 100 icu = 1, 2
1648 uplo = ichu( icu: icu )
1649 upper = uplo.EQ.'U'
1650*
1651 DO 90 ia = 1, nalf
1652 alpha = alf( ia )
1653*
1654 DO 80 ib = 1, nbet
1655 beta = bet( ib )
1656*
1657* Generate the matrix C.
1658*
1659 CALL dmake( 'SY', uplo, ' ', n, n, c, nmax, cc,
1660 $ ldc, reset, zero )
1661*
1662 nc = nc + 1
1663*
1664* Save every datum before calling the subroutine.
1665*
1666 uplos = uplo
1667 transs = trans
1668 ns = n
1669 ks = k
1670 als = alpha
1671 DO 10 i = 1, laa
1672 as( i ) = aa( i )
1673 10 CONTINUE
1674 ldas = lda
1675 DO 20 i = 1, lbb
1676 bs( i ) = bb( i )
1677 20 CONTINUE
1678 ldbs = ldb
1679 bets = beta
1680 DO 30 i = 1, lcc
1681 cs( i ) = cc( i )
1682 30 CONTINUE
1683 ldcs = ldc
1684*
1685* Call the subroutine.
1686*
1687 IF( trace )
1688 $ WRITE( ntra, fmt = 9994 )nc, sname, uplo,
1689 $ trans, n, k, alpha, lda, ldb, beta, ldc
1690 IF( rewi )
1691 $ rewind ntra
1692 CALL dsyr2k( uplo, trans, n, k, alpha, aa, lda,
1693 $ bb, ldb, beta, cc, ldc )
1694*
1695* Check if error-exit was taken incorrectly.
1696*
1697 IF( .NOT.ok )THEN
1698 WRITE( nout, fmt = 9993 )
1699 fatal = .true.
1700 GO TO 150
1701 END IF
1702*
1703* See what data changed inside subroutines.
1704*
1705 isame( 1 ) = uplos.EQ.uplo
1706 isame( 2 ) = transs.EQ.trans
1707 isame( 3 ) = ns.EQ.n
1708 isame( 4 ) = ks.EQ.k
1709 isame( 5 ) = als.EQ.alpha
1710 isame( 6 ) = lde( as, aa, laa )
1711 isame( 7 ) = ldas.EQ.lda
1712 isame( 8 ) = lde( bs, bb, lbb )
1713 isame( 9 ) = ldbs.EQ.ldb
1714 isame( 10 ) = bets.EQ.beta
1715 IF( null )THEN
1716 isame( 11 ) = lde( cs, cc, lcc )
1717 ELSE
1718 isame( 11 ) = lderes( 'SY', uplo, n, n, cs,
1719 $ cc, ldc )
1720 END IF
1721 isame( 12 ) = ldcs.EQ.ldc
1722*
1723* If data was incorrectly changed, report and
1724* return.
1725*
1726 same = .true.
1727 DO 40 i = 1, nargs
1728 same = same.AND.isame( i )
1729 IF( .NOT.isame( i ) )
1730 $ WRITE( nout, fmt = 9998 )i
1731 40 CONTINUE
1732 IF( .NOT.same )THEN
1733 fatal = .true.
1734 GO TO 150
1735 END IF
1736*
1737 IF( .NOT.null )THEN
1738*
1739* Check the result column by column.
1740*
1741 jjab = 1
1742 jc = 1
1743 DO 70 j = 1, n
1744 IF( upper )THEN
1745 jj = 1
1746 lj = j
1747 ELSE
1748 jj = j
1749 lj = n - j + 1
1750 END IF
1751 IF( tran )THEN
1752 DO 50 i = 1, k
1753 w( i ) = ab( ( j - 1 )*2*nmax + k +
1754 $ i )
1755 w( k + i ) = ab( ( j - 1 )*2*nmax +
1756 $ i )
1757 50 CONTINUE
1758 CALL dmmch( 'T', 'N', lj, 1, 2*k,
1759 $ alpha, ab( jjab ), 2*nmax,
1760 $ w, 2*nmax, beta,
1761 $ c( jj, j ), nmax, ct, g,
1762 $ cc( jc ), ldc, eps, err,
1763 $ fatal, nout, .true. )
1764 ELSE
1765 DO 60 i = 1, k
1766 w( i ) = ab( ( k + i - 1 )*nmax +
1767 $ j )
1768 w( k + i ) = ab( ( i - 1 )*nmax +
1769 $ j )
1770 60 CONTINUE
1771 CALL dmmch( 'N', 'N', lj, 1, 2*k,
1772 $ alpha, ab( jj ), nmax, w,
1773 $ 2*nmax, beta, c( jj, j ),
1774 $ nmax, ct, g, cc( jc ), ldc,
1775 $ eps, err, fatal, nout,
1776 $ .true. )
1777 END IF
1778 IF( upper )THEN
1779 jc = jc + ldc
1780 ELSE
1781 jc = jc + ldc + 1
1782 IF( tran )
1783 $ jjab = jjab + 2*nmax
1784 END IF
1785 errmax = max( errmax, err )
1786* If got really bad answer, report and
1787* return.
1788 IF( fatal )
1789 $ GO TO 140
1790 70 CONTINUE
1791 END IF
1792*
1793 80 CONTINUE
1794*
1795 90 CONTINUE
1796*
1797 100 CONTINUE
1798*
1799 110 CONTINUE
1800*
1801 120 CONTINUE
1802*
1803 130 CONTINUE
1804*
1805* Report result.
1806*
1807 IF( errmax.LT.thresh )THEN
1808 WRITE( nout, fmt = 9999 )sname, nc
1809 ELSE
1810 WRITE( nout, fmt = 9997 )sname, nc, errmax
1811 END IF
1812 GO TO 160
1813*
1814 140 CONTINUE
1815 IF( n.GT.1 )
1816 $ WRITE( nout, fmt = 9995 )j
1817*
1818 150 CONTINUE
1819 WRITE( nout, fmt = 9996 )sname
1820 WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, n, k, alpha,
1821 $ lda, ldb, beta, ldc
1822*
1823 160 CONTINUE
1824 RETURN
1825*
1826 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1827 $ 'S)' )
1828 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1829 $ 'ANGED INCORRECTLY *******' )
1830 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1831 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1832 $ ' - SUSPECT *******' )
1833 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1834 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1835 9994 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1836 $ f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', C,', i3, ') ',
1837 $ ' .' )
1838 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1839 $ '******' )
1840*
1841* End of DCHK5
1842*
1843 END
1844 SUBROUTINE dchke( ISNUM, SRNAMT, NOUT )
1845*
1846* Tests the error exits from the Level 3 Blas.
1847* Requires a special version of the error-handling routine XERBLA.
1848* A, B and C should not need to be defined.
1849*
1850* Auxiliary routine for test program for Level 3 Blas.
1851*
1852* -- Written on 8-February-1989.
1853* Jack Dongarra, Argonne National Laboratory.
1854* Iain Duff, AERE Harwell.
1855* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1856* Sven Hammarling, Numerical Algorithms Group Ltd.
1857*
1858* 3-19-92: Initialize ALPHA and BETA (eca)
1859* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca)
1860*
1861* .. Scalar Arguments ..
1862 INTEGER ISNUM, NOUT
1863 CHARACTER*7 SRNAMT
1864* .. Scalars in Common ..
1865 INTEGER INFOT, NOUTC
1866 LOGICAL LERR, OK
1867* .. Parameters ..
1868 DOUBLE PRECISION ONE, TWO
1869 PARAMETER ( ONE = 1.0d0, two = 2.0d0 )
1870* .. Local Scalars ..
1871 DOUBLE PRECISION ALPHA, BETA
1872* .. Local Arrays ..
1873 DOUBLE PRECISION A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
1874* .. External Subroutines ..
1875 EXTERNAL chkxer, dgemm, dsymm, dsyr2k, dsyrk, dtrmm,
1876 $ dtrsm
1877* .. Common blocks ..
1878 COMMON /infoc/infot, noutc, ok, lerr
1879* .. Executable Statements ..
1880* OK is set to .FALSE. by the special version of XERBLA or by CHKXER
1881* if anything is wrong.
1882 ok = .true.
1883* LERR is set to .TRUE. by the special version of XERBLA each time
1884* it is called, and is then tested and re-set by CHKXER.
1885 lerr = .false.
1886*
1887* Initialize ALPHA and BETA.
1888*
1889 alpha = one
1890 beta = two
1891*
1892 GO TO ( 10, 20, 30, 40, 50, 60, 70 )isnum
1893 10 infot = 1
1894 CALL dgemm( '/', 'N', 0, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1895 CALL chkxer( srnamt, infot, nout, lerr, ok )
1896 infot = 1
1897 CALL dgemm( '/', 'T', 0, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1898 CALL chkxer( srnamt, infot, nout, lerr, ok )
1899 infot = 2
1900 CALL dgemm( 'N', '/', 0, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1901 CALL chkxer( srnamt, infot, nout, lerr, ok )
1902 infot = 2
1903 CALL dgemm( 'T', '/', 0, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1904 CALL chkxer( srnamt, infot, nout, lerr, ok )
1905 infot = 3
1906 CALL dgemm( 'N', 'N', -1, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1907 CALL chkxer( srnamt, infot, nout, lerr, ok )
1908 infot = 3
1909 CALL dgemm( 'N', 'T', -1, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1910 CALL chkxer( srnamt, infot, nout, lerr, ok )
1911 infot = 3
1912 CALL dgemm( 'T', 'N', -1, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1913 CALL chkxer( srnamt, infot, nout, lerr, ok )
1914 infot = 3
1915 CALL dgemm( 'T', 'T', -1, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1916 CALL chkxer( srnamt, infot, nout, lerr, ok )
1917 infot = 4
1918 CALL dgemm( 'N', 'N', 0, -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1919 CALL chkxer( srnamt, infot, nout, lerr, ok )
1920 infot = 4
1921 CALL dgemm( 'N', 'T', 0, -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1922 CALL chkxer( srnamt, infot, nout, lerr, ok )
1923 infot = 4
1924 CALL dgemm( 'T', 'N', 0, -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1925 CALL chkxer( srnamt, infot, nout, lerr, ok )
1926 infot = 4
1927 CALL dgemm( 'T', 'T', 0, -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1928 CALL chkxer( srnamt, infot, nout, lerr, ok )
1929 infot = 5
1930 CALL dgemm( 'N', 'N', 0, 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
1931 CALL chkxer( srnamt, infot, nout, lerr, ok )
1932 infot = 5
1933 CALL dgemm( 'N', 'T', 0, 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
1934 CALL chkxer( srnamt, infot, nout, lerr, ok )
1935 infot = 5
1936 CALL dgemm( 'T', 'N', 0, 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
1937 CALL chkxer( srnamt, infot, nout, lerr, ok )
1938 infot = 5
1939 CALL dgemm( 'T', 'T', 0, 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
1940 CALL chkxer( srnamt, infot, nout, lerr, ok )
1941 infot = 8
1942 CALL dgemm( 'N', 'N', 2, 0, 0, alpha, a, 1, b, 1, beta, c, 2 )
1943 CALL chkxer( srnamt, infot, nout, lerr, ok )
1944 infot = 8
1945 CALL dgemm( 'N', 'T', 2, 0, 0, alpha, a, 1, b, 1, beta, c, 2 )
1946 CALL chkxer( srnamt, infot, nout, lerr, ok )
1947 infot = 8
1948 CALL dgemm( 'T', 'N', 0, 0, 2, alpha, a, 1, b, 2, beta, c, 1 )
1949 CALL chkxer( srnamt, infot, nout, lerr, ok )
1950 infot = 8
1951 CALL dgemm( 'T', 'T', 0, 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
1952 CALL chkxer( srnamt, infot, nout, lerr, ok )
1953 infot = 10
1954 CALL dgemm( 'N', 'N', 0, 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
1955 CALL chkxer( srnamt, infot, nout, lerr, ok )
1956 infot = 10
1957 CALL dgemm( 'T', 'N', 0, 0, 2, alpha, a, 2, b, 1, beta, c, 1 )
1958 CALL chkxer( srnamt, infot, nout, lerr, ok )
1959 infot = 10
1960 CALL dgemm( 'N', 'T', 0, 2, 0, alpha, a, 1, b, 1, beta, c, 1 )
1961 CALL chkxer( srnamt, infot, nout, lerr, ok )
1962 infot = 10
1963 CALL dgemm( 'T', 'T', 0, 2, 0, alpha, a, 1, b, 1, beta, c, 1 )
1964 CALL chkxer( srnamt, infot, nout, lerr, ok )
1965 infot = 13
1966 CALL dgemm( 'N', 'N', 2, 0, 0, alpha, a, 2, b, 1, beta, c, 1 )
1967 CALL chkxer( srnamt, infot, nout, lerr, ok )
1968 infot = 13
1969 CALL dgemm( 'N', 'T', 2, 0, 0, alpha, a, 2, b, 1, beta, c, 1 )
1970 CALL chkxer( srnamt, infot, nout, lerr, ok )
1971 infot = 13
1972 CALL dgemm( 'T', 'N', 2, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1973 CALL chkxer( srnamt, infot, nout, lerr, ok )
1974 infot = 13
1975 CALL dgemm( 'T', 'T', 2, 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1976 CALL chkxer( srnamt, infot, nout, lerr, ok )
1977 GO TO 80
1978 20 infot = 1
1979 CALL dsymm( '/', 'U', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1980 CALL chkxer( srnamt, infot, nout, lerr, ok )
1981 infot = 2
1982 CALL dsymm( 'L', '/', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
1983 CALL chkxer( srnamt, infot, nout, lerr, ok )
1984 infot = 3
1985 CALL dsymm( 'L', 'U', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1986 CALL chkxer( srnamt, infot, nout, lerr, ok )
1987 infot = 3
1988 CALL dsymm( 'R', 'U', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1989 CALL chkxer( srnamt, infot, nout, lerr, ok )
1990 infot = 3
1991 CALL dsymm( 'L', 'L', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1992 CALL chkxer( srnamt, infot, nout, lerr, ok )
1993 infot = 3
1994 CALL dsymm( 'R', 'L', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
1995 CALL chkxer( srnamt, infot, nout, lerr, ok )
1996 infot = 4
1997 CALL dsymm( 'L', 'U', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
1998 CALL chkxer( srnamt, infot, nout, lerr, ok )
1999 infot = 4
2000 CALL dsymm( 'R', 'U', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2001 CALL chkxer( srnamt, infot, nout, lerr, ok )
2002 infot = 4
2003 CALL dsymm( 'L', 'L', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2004 CALL chkxer( srnamt, infot, nout, lerr, ok )
2005 infot = 4
2006 CALL dsymm( 'R', 'L', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2007 CALL chkxer( srnamt, infot, nout, lerr, ok )
2008 infot = 7
2009 CALL dsymm( 'L', 'U', 2, 0, alpha, a, 1, b, 2, beta, c, 2 )
2010 CALL chkxer( srnamt, infot, nout, lerr, ok )
2011 infot = 7
2012 CALL dsymm( 'R', 'U', 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
2013 CALL chkxer( srnamt, infot, nout, lerr, ok )
2014 infot = 7
2015 CALL dsymm( 'L', 'L', 2, 0, alpha, a, 1, b, 2, beta, c, 2 )
2016 CALL chkxer( srnamt, infot, nout, lerr, ok )
2017 infot = 7
2018 CALL dsymm( 'R', 'L', 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
2019 CALL chkxer( srnamt, infot, nout, lerr, ok )
2020 infot = 9
2021 CALL dsymm( 'L', 'U', 2, 0, alpha, a, 2, b, 1, beta, c, 2 )
2022 CALL chkxer( srnamt, infot, nout, lerr, ok )
2023 infot = 9
2024 CALL dsymm( 'R', 'U', 2, 0, alpha, a, 1, b, 1, beta, c, 2 )
2025 CALL chkxer( srnamt, infot, nout, lerr, ok )
2026 infot = 9
2027 CALL dsymm( 'L', 'L', 2, 0, alpha, a, 2, b, 1, beta, c, 2 )
2028 CALL chkxer( srnamt, infot, nout, lerr, ok )
2029 infot = 9
2030 CALL dsymm( 'R', 'L', 2, 0, alpha, a, 1, b, 1, beta, c, 2 )
2031 CALL chkxer( srnamt, infot, nout, lerr, ok )
2032 infot = 12
2033 CALL dsymm( 'L', 'U', 2, 0, alpha, a, 2, b, 2, beta, c, 1 )
2034 CALL chkxer( srnamt, infot, nout, lerr, ok )
2035 infot = 12
2036 CALL dsymm( 'R', 'U', 2, 0, alpha, a, 1, b, 2, beta, c, 1 )
2037 CALL chkxer( srnamt, infot, nout, lerr, ok )
2038 infot = 12
2039 CALL dsymm( 'L', 'L', 2, 0, alpha, a, 2, b, 2, beta, c, 1 )
2040 CALL chkxer( srnamt, infot, nout, lerr, ok )
2041 infot = 12
2042 CALL dsymm( 'R', 'L', 2, 0, alpha, a, 1, b, 2, beta, c, 1 )
2043 CALL chkxer( srnamt, infot, nout, lerr, ok )
2044 GO TO 80
2045 30 infot = 1
2046 CALL dtrmm( '/', 'U', 'N', 'N', 0, 0, alpha, a, 1, b, 1 )
2047 CALL chkxer( srnamt, infot, nout, lerr, ok )
2048 infot = 2
2049 CALL dtrmm( 'L', '/', 'N', 'N', 0, 0, alpha, a, 1, b, 1 )
2050 CALL chkxer( srnamt, infot, nout, lerr, ok )
2051 infot = 3
2052 CALL dtrmm( 'L', 'U', '/', 'N', 0, 0, alpha, a, 1, b, 1 )
2053 CALL chkxer( srnamt, infot, nout, lerr, ok )
2054 infot = 4
2055 CALL dtrmm( 'L', 'U', 'N', '/', 0, 0, alpha, a, 1, b, 1 )
2056 CALL chkxer( srnamt, infot, nout, lerr, ok )
2057 infot = 5
2058 CALL dtrmm( 'L', 'U', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2059 CALL chkxer( srnamt, infot, nout, lerr, ok )
2060 infot = 5
2061 CALL dtrmm( 'L', 'U', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2062 CALL chkxer( srnamt, infot, nout, lerr, ok )
2063 infot = 5
2064 CALL dtrmm( 'R', 'U', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2065 CALL chkxer( srnamt, infot, nout, lerr, ok )
2066 infot = 5
2067 CALL dtrmm( 'R', 'U', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2068 CALL chkxer( srnamt, infot, nout, lerr, ok )
2069 infot = 5
2070 CALL dtrmm( 'L', 'L', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2071 CALL chkxer( srnamt, infot, nout, lerr, ok )
2072 infot = 5
2073 CALL dtrmm( 'L', 'L', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2074 CALL chkxer( srnamt, infot, nout, lerr, ok )
2075 infot = 5
2076 CALL dtrmm( 'R', 'L', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2077 CALL chkxer( srnamt, infot, nout, lerr, ok )
2078 infot = 5
2079 CALL dtrmm( 'R', 'L', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2080 CALL chkxer( srnamt, infot, nout, lerr, ok )
2081 infot = 6
2082 CALL dtrmm( 'L', 'U', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2083 CALL chkxer( srnamt, infot, nout, lerr, ok )
2084 infot = 6
2085 CALL dtrmm( 'L', 'U', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2086 CALL chkxer( srnamt, infot, nout, lerr, ok )
2087 infot = 6
2088 CALL dtrmm( 'R', 'U', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2089 CALL chkxer( srnamt, infot, nout, lerr, ok )
2090 infot = 6
2091 CALL dtrmm( 'R', 'U', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2092 CALL chkxer( srnamt, infot, nout, lerr, ok )
2093 infot = 6
2094 CALL dtrmm( 'L', 'L', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2095 CALL chkxer( srnamt, infot, nout, lerr, ok )
2096 infot = 6
2097 CALL dtrmm( 'L', 'L', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2098 CALL chkxer( srnamt, infot, nout, lerr, ok )
2099 infot = 6
2100 CALL dtrmm( 'R', 'L', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2101 CALL chkxer( srnamt, infot, nout, lerr, ok )
2102 infot = 6
2103 CALL dtrmm( 'R', 'L', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2104 CALL chkxer( srnamt, infot, nout, lerr, ok )
2105 infot = 9
2106 CALL dtrmm( 'L', 'U', 'N', 'N', 2, 0, alpha, a, 1, b, 2 )
2107 CALL chkxer( srnamt, infot, nout, lerr, ok )
2108 infot = 9
2109 CALL dtrmm( 'L', 'U', 'T', 'N', 2, 0, alpha, a, 1, b, 2 )
2110 CALL chkxer( srnamt, infot, nout, lerr, ok )
2111 infot = 9
2112 CALL dtrmm( 'R', 'U', 'N', 'N', 0, 2, alpha, a, 1, b, 1 )
2113 CALL chkxer( srnamt, infot, nout, lerr, ok )
2114 infot = 9
2115 CALL dtrmm( 'R', 'U', 'T', 'N', 0, 2, alpha, a, 1, b, 1 )
2116 CALL chkxer( srnamt, infot, nout, lerr, ok )
2117 infot = 9
2118 CALL dtrmm( 'L', 'L', 'N', 'N', 2, 0, alpha, a, 1, b, 2 )
2119 CALL chkxer( srnamt, infot, nout, lerr, ok )
2120 infot = 9
2121 CALL dtrmm( 'L', 'L', 'T', 'N', 2, 0, alpha, a, 1, b, 2 )
2122 CALL chkxer( srnamt, infot, nout, lerr, ok )
2123 infot = 9
2124 CALL dtrmm( 'R', 'L', 'N', 'N', 0, 2, alpha, a, 1, b, 1 )
2125 CALL chkxer( srnamt, infot, nout, lerr, ok )
2126 infot = 9
2127 CALL dtrmm( 'R', 'L', 'T', 'N', 0, 2, alpha, a, 1, b, 1 )
2128 CALL chkxer( srnamt, infot, nout, lerr, ok )
2129 infot = 11
2130 CALL dtrmm( 'L', 'U', 'N', 'N', 2, 0, alpha, a, 2, b, 1 )
2131 CALL chkxer( srnamt, infot, nout, lerr, ok )
2132 infot = 11
2133 CALL dtrmm( 'L', 'U', 'T', 'N', 2, 0, alpha, a, 2, b, 1 )
2134 CALL chkxer( srnamt, infot, nout, lerr, ok )
2135 infot = 11
2136 CALL dtrmm( 'R', 'U', 'N', 'N', 2, 0, alpha, a, 1, b, 1 )
2137 CALL chkxer( srnamt, infot, nout, lerr, ok )
2138 infot = 11
2139 CALL dtrmm( 'R', 'U', 'T', 'N', 2, 0, alpha, a, 1, b, 1 )
2140 CALL chkxer( srnamt, infot, nout, lerr, ok )
2141 infot = 11
2142 CALL dtrmm( 'L', 'L', 'N', 'N', 2, 0, alpha, a, 2, b, 1 )
2143 CALL chkxer( srnamt, infot, nout, lerr, ok )
2144 infot = 11
2145 CALL dtrmm( 'L', 'L', 'T', 'N', 2, 0, alpha, a, 2, b, 1 )
2146 CALL chkxer( srnamt, infot, nout, lerr, ok )
2147 infot = 11
2148 CALL dtrmm( 'R', 'L', 'N', 'N', 2, 0, alpha, a, 1, b, 1 )
2149 CALL chkxer( srnamt, infot, nout, lerr, ok )
2150 infot = 11
2151 CALL dtrmm( 'R', 'L', 'T', 'N', 2, 0, alpha, a, 1, b, 1 )
2152 CALL chkxer( srnamt, infot, nout, lerr, ok )
2153 GO TO 80
2154 40 infot = 1
2155 CALL dtrsm( '/', 'U', 'N', 'N', 0, 0, alpha, a, 1, b, 1 )
2156 CALL chkxer( srnamt, infot, nout, lerr, ok )
2157 infot = 2
2158 CALL dtrsm( 'L', '/', 'N', 'N', 0, 0, alpha, a, 1, b, 1 )
2159 CALL chkxer( srnamt, infot, nout, lerr, ok )
2160 infot = 3
2161 CALL dtrsm( 'L', 'U', '/', 'N', 0, 0, alpha, a, 1, b, 1 )
2162 CALL chkxer( srnamt, infot, nout, lerr, ok )
2163 infot = 4
2164 CALL dtrsm( 'L', 'U', 'N', '/', 0, 0, alpha, a, 1, b, 1 )
2165 CALL chkxer( srnamt, infot, nout, lerr, ok )
2166 infot = 5
2167 CALL dtrsm( 'L', 'U', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2168 CALL chkxer( srnamt, infot, nout, lerr, ok )
2169 infot = 5
2170 CALL dtrsm( 'L', 'U', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2171 CALL chkxer( srnamt, infot, nout, lerr, ok )
2172 infot = 5
2173 CALL dtrsm( 'R', 'U', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2174 CALL chkxer( srnamt, infot, nout, lerr, ok )
2175 infot = 5
2176 CALL dtrsm( 'R', 'U', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2177 CALL chkxer( srnamt, infot, nout, lerr, ok )
2178 infot = 5
2179 CALL dtrsm( 'L', 'L', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2180 CALL chkxer( srnamt, infot, nout, lerr, ok )
2181 infot = 5
2182 CALL dtrsm( 'L', 'L', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2183 CALL chkxer( srnamt, infot, nout, lerr, ok )
2184 infot = 5
2185 CALL dtrsm( 'R', 'L', 'N', 'N', -1, 0, alpha, a, 1, b, 1 )
2186 CALL chkxer( srnamt, infot, nout, lerr, ok )
2187 infot = 5
2188 CALL dtrsm( 'R', 'L', 'T', 'N', -1, 0, alpha, a, 1, b, 1 )
2189 CALL chkxer( srnamt, infot, nout, lerr, ok )
2190 infot = 6
2191 CALL dtrsm( 'L', 'U', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2192 CALL chkxer( srnamt, infot, nout, lerr, ok )
2193 infot = 6
2194 CALL dtrsm( 'L', 'U', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2195 CALL chkxer( srnamt, infot, nout, lerr, ok )
2196 infot = 6
2197 CALL dtrsm( 'R', 'U', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2198 CALL chkxer( srnamt, infot, nout, lerr, ok )
2199 infot = 6
2200 CALL dtrsm( 'R', 'U', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2201 CALL chkxer( srnamt, infot, nout, lerr, ok )
2202 infot = 6
2203 CALL dtrsm( 'L', 'L', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2204 CALL chkxer( srnamt, infot, nout, lerr, ok )
2205 infot = 6
2206 CALL dtrsm( 'L', 'L', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2207 CALL chkxer( srnamt, infot, nout, lerr, ok )
2208 infot = 6
2209 CALL dtrsm( 'R', 'L', 'N', 'N', 0, -1, alpha, a, 1, b, 1 )
2210 CALL chkxer( srnamt, infot, nout, lerr, ok )
2211 infot = 6
2212 CALL dtrsm( 'R', 'L', 'T', 'N', 0, -1, alpha, a, 1, b, 1 )
2213 CALL chkxer( srnamt, infot, nout, lerr, ok )
2214 infot = 9
2215 CALL dtrsm( 'L', 'U', 'N', 'N', 2, 0, alpha, a, 1, b, 2 )
2216 CALL chkxer( srnamt, infot, nout, lerr, ok )
2217 infot = 9
2218 CALL dtrsm( 'L', 'U', 'T', 'N', 2, 0, alpha, a, 1, b, 2 )
2219 CALL chkxer( srnamt, infot, nout, lerr, ok )
2220 infot = 9
2221 CALL dtrsm( 'R', 'U', 'N', 'N', 0, 2, alpha, a, 1, b, 1 )
2222 CALL chkxer( srnamt, infot, nout, lerr, ok )
2223 infot = 9
2224 CALL dtrsm( 'R', 'U', 'T', 'N', 0, 2, alpha, a, 1, b, 1 )
2225 CALL chkxer( srnamt, infot, nout, lerr, ok )
2226 infot = 9
2227 CALL dtrsm( 'L', 'L', 'N', 'N', 2, 0, alpha, a, 1, b, 2 )
2228 CALL chkxer( srnamt, infot, nout, lerr, ok )
2229 infot = 9
2230 CALL dtrsm( 'L', 'L', 'T', 'N', 2, 0, alpha, a, 1, b, 2 )
2231 CALL chkxer( srnamt, infot, nout, lerr, ok )
2232 infot = 9
2233 CALL dtrsm( 'R', 'L', 'N', 'N', 0, 2, alpha, a, 1, b, 1 )
2234 CALL chkxer( srnamt, infot, nout, lerr, ok )
2235 infot = 9
2236 CALL dtrsm( 'R', 'L', 'T', 'N', 0, 2, alpha, a, 1, b, 1 )
2237 CALL chkxer( srnamt, infot, nout, lerr, ok )
2238 infot = 11
2239 CALL dtrsm( 'L', 'U', 'N', 'N', 2, 0, alpha, a, 2, b, 1 )
2240 CALL chkxer( srnamt, infot, nout, lerr, ok )
2241 infot = 11
2242 CALL dtrsm( 'L', 'U', 'T', 'N', 2, 0, alpha, a, 2, b, 1 )
2243 CALL chkxer( srnamt, infot, nout, lerr, ok )
2244 infot = 11
2245 CALL dtrsm( 'R', 'U', 'N', 'N', 2, 0, alpha, a, 1, b, 1 )
2246 CALL chkxer( srnamt, infot, nout, lerr, ok )
2247 infot = 11
2248 CALL dtrsm( 'R', 'U', 'T', 'N', 2, 0, alpha, a, 1, b, 1 )
2249 CALL chkxer( srnamt, infot, nout, lerr, ok )
2250 infot = 11
2251 CALL dtrsm( 'L', 'L', 'N', 'N', 2, 0, alpha, a, 2, b, 1 )
2252 CALL chkxer( srnamt, infot, nout, lerr, ok )
2253 infot = 11
2254 CALL dtrsm( 'L', 'L', 'T', 'N', 2, 0, alpha, a, 2, b, 1 )
2255 CALL chkxer( srnamt, infot, nout, lerr, ok )
2256 infot = 11
2257 CALL dtrsm( 'R', 'L', 'N', 'N', 2, 0, alpha, a, 1, b, 1 )
2258 CALL chkxer( srnamt, infot, nout, lerr, ok )
2259 infot = 11
2260 CALL dtrsm( 'R', 'L', 'T', 'N', 2, 0, alpha, a, 1, b, 1 )
2261 CALL chkxer( srnamt, infot, nout, lerr, ok )
2262 GO TO 80
2263 50 infot = 1
2264 CALL dsyrk( '/', 'N', 0, 0, alpha, a, 1, beta, c, 1 )
2265 CALL chkxer( srnamt, infot, nout, lerr, ok )
2266 infot = 2
2267 CALL dsyrk( 'U', '/', 0, 0, alpha, a, 1, beta, c, 1 )
2268 CALL chkxer( srnamt, infot, nout, lerr, ok )
2269 infot = 3
2270 CALL dsyrk( 'U', 'N', -1, 0, alpha, a, 1, beta, c, 1 )
2271 CALL chkxer( srnamt, infot, nout, lerr, ok )
2272 infot = 3
2273 CALL dsyrk( 'U', 'T', -1, 0, alpha, a, 1, beta, c, 1 )
2274 CALL chkxer( srnamt, infot, nout, lerr, ok )
2275 infot = 3
2276 CALL dsyrk( 'L', 'N', -1, 0, alpha, a, 1, beta, c, 1 )
2277 CALL chkxer( srnamt, infot, nout, lerr, ok )
2278 infot = 3
2279 CALL dsyrk( 'L', 'T', -1, 0, alpha, a, 1, beta, c, 1 )
2280 CALL chkxer( srnamt, infot, nout, lerr, ok )
2281 infot = 4
2282 CALL dsyrk( 'U', 'N', 0, -1, alpha, a, 1, beta, c, 1 )
2283 CALL chkxer( srnamt, infot, nout, lerr, ok )
2284 infot = 4
2285 CALL dsyrk( 'U', 'T', 0, -1, alpha, a, 1, beta, c, 1 )
2286 CALL chkxer( srnamt, infot, nout, lerr, ok )
2287 infot = 4
2288 CALL dsyrk( 'L', 'N', 0, -1, alpha, a, 1, beta, c, 1 )
2289 CALL chkxer( srnamt, infot, nout, lerr, ok )
2290 infot = 4
2291 CALL dsyrk( 'L', 'T', 0, -1, alpha, a, 1, beta, c, 1 )
2292 CALL chkxer( srnamt, infot, nout, lerr, ok )
2293 infot = 7
2294 CALL dsyrk( 'U', 'N', 2, 0, alpha, a, 1, beta, c, 2 )
2295 CALL chkxer( srnamt, infot, nout, lerr, ok )
2296 infot = 7
2297 CALL dsyrk( 'U', 'T', 0, 2, alpha, a, 1, beta, c, 1 )
2298 CALL chkxer( srnamt, infot, nout, lerr, ok )
2299 infot = 7
2300 CALL dsyrk( 'L', 'N', 2, 0, alpha, a, 1, beta, c, 2 )
2301 CALL chkxer( srnamt, infot, nout, lerr, ok )
2302 infot = 7
2303 CALL dsyrk( 'L', 'T', 0, 2, alpha, a, 1, beta, c, 1 )
2304 CALL chkxer( srnamt, infot, nout, lerr, ok )
2305 infot = 10
2306 CALL dsyrk( 'U', 'N', 2, 0, alpha, a, 2, beta, c, 1 )
2307 CALL chkxer( srnamt, infot, nout, lerr, ok )
2308 infot = 10
2309 CALL dsyrk( 'U', 'T', 2, 0, alpha, a, 1, beta, c, 1 )
2310 CALL chkxer( srnamt, infot, nout, lerr, ok )
2311 infot = 10
2312 CALL dsyrk( 'L', 'N', 2, 0, alpha, a, 2, beta, c, 1 )
2313 CALL chkxer( srnamt, infot, nout, lerr, ok )
2314 infot = 10
2315 CALL dsyrk( 'L', 'T', 2, 0, alpha, a, 1, beta, c, 1 )
2316 CALL chkxer( srnamt, infot, nout, lerr, ok )
2317 GO TO 80
2318 60 infot = 1
2319 CALL dsyr2k( '/', 'N', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
2320 CALL chkxer( srnamt, infot, nout, lerr, ok )
2321 infot = 2
2322 CALL dsyr2k( 'U', '/', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
2323 CALL chkxer( srnamt, infot, nout, lerr, ok )
2324 infot = 3
2325 CALL dsyr2k( 'U', 'N', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
2326 CALL chkxer( srnamt, infot, nout, lerr, ok )
2327 infot = 3
2328 CALL dsyr2k( 'U', 'T', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
2329 CALL chkxer( srnamt, infot, nout, lerr, ok )
2330 infot = 3
2331 CALL dsyr2k( 'L', 'N', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
2332 CALL chkxer( srnamt, infot, nout, lerr, ok )
2333 infot = 3
2334 CALL dsyr2k( 'L', 'T', -1, 0, alpha, a, 1, b, 1, beta, c, 1 )
2335 CALL chkxer( srnamt, infot, nout, lerr, ok )
2336 infot = 4
2337 CALL dsyr2k( 'U', 'N', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2338 CALL chkxer( srnamt, infot, nout, lerr, ok )
2339 infot = 4
2340 CALL dsyr2k( 'U', 'T', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2341 CALL chkxer( srnamt, infot, nout, lerr, ok )
2342 infot = 4
2343 CALL dsyr2k( 'L', 'N', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2344 CALL chkxer( srnamt, infot, nout, lerr, ok )
2345 infot = 4
2346 CALL dsyr2k( 'L', 'T', 0, -1, alpha, a, 1, b, 1, beta, c, 1 )
2347 CALL chkxer( srnamt, infot, nout, lerr, ok )
2348 infot = 7
2349 CALL dsyr2k( 'U', 'N', 2, 0, alpha, a, 1, b, 1, beta, c, 2 )
2350 CALL chkxer( srnamt, infot, nout, lerr, ok )
2351 infot = 7
2352 CALL dsyr2k( 'U', 'T', 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
2353 CALL chkxer( srnamt, infot, nout, lerr, ok )
2354 infot = 7
2355 CALL dsyr2k( 'L', 'N', 2, 0, alpha, a, 1, b, 1, beta, c, 2 )
2356 CALL chkxer( srnamt, infot, nout, lerr, ok )
2357 infot = 7
2358 CALL dsyr2k( 'L', 'T', 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
2359 CALL chkxer( srnamt, infot, nout, lerr, ok )
2360 infot = 9
2361 CALL dsyr2k( 'U', 'N', 2, 0, alpha, a, 2, b, 1, beta, c, 2 )
2362 CALL chkxer( srnamt, infot, nout, lerr, ok )
2363 infot = 9
2364 CALL dsyr2k( 'U', 'T', 0, 2, alpha, a, 2, b, 1, beta, c, 1 )
2365 CALL chkxer( srnamt, infot, nout, lerr, ok )
2366 infot = 9
2367 CALL dsyr2k( 'L', 'N', 2, 0, alpha, a, 2, b, 1, beta, c, 2 )
2368 CALL chkxer( srnamt, infot, nout, lerr, ok )
2369 infot = 9
2370 CALL dsyr2k( 'L', 'T', 0, 2, alpha, a, 2, b, 1, beta, c, 1 )
2371 CALL chkxer( srnamt, infot, nout, lerr, ok )
2372 infot = 12
2373 CALL dsyr2k( 'U', 'N', 2, 0, alpha, a, 2, b, 2, beta, c, 1 )
2374 CALL chkxer( srnamt, infot, nout, lerr, ok )
2375 infot = 12
2376 CALL dsyr2k( 'U', 'T', 2, 0, alpha, a, 1, b, 1, beta, c, 1 )
2377 CALL chkxer( srnamt, infot, nout, lerr, ok )
2378 infot = 12
2379 CALL dsyr2k( 'L', 'N', 2, 0, alpha, a, 2, b, 2, beta, c, 1 )
2380 CALL chkxer( srnamt, infot, nout, lerr, ok )
2381 infot = 12
2382 CALL dsyr2k( 'L', 'T', 2, 0, alpha, a, 1, b, 1, beta, c, 1 )
2383 CALL chkxer( srnamt, infot, nout, lerr, ok )
2384 GO TO 80
2385 70 infot = 1
2386 CALL dgemmtr( '/', 'N', 'N', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
2387 CALL chkxer( srnamt, infot, nout, lerr, ok )
2388 infot = 2
2389 CALL dgemmtr( 'U', '/', 'N', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
2390 CALL chkxer( srnamt, infot, nout, lerr, ok )
2391 infot = 2
2392 CALL dgemmtr( 'U', '/', 'T', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
2393 CALL chkxer( srnamt, infot, nout, lerr, ok )
2394 infot = 3
2395 CALL dgemmtr( 'U', 'N', '/', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
2396 CALL chkxer( srnamt, infot, nout, lerr, ok )
2397 infot = 3
2398 CALL dgemmtr( 'U', 'T', '/', 0, 0, alpha, a, 1, b, 1, beta, c, 1 )
2399 CALL chkxer( srnamt, infot, nout, lerr, ok )
2400 infot = 4
2401 CALL dgemmtr( 'U', 'N', 'N', -1, 0, alpha, a, 1, b, 1, beta, c,
2402 $ 1 )
2403 CALL chkxer( srnamt, infot, nout, lerr, ok )
2404 infot = 4
2405 CALL dgemmtr( 'U', 'N', 'T', -1, 0, alpha, a, 1, b, 1, beta, c,
2406 $ 1 )
2407 CALL chkxer( srnamt, infot, nout, lerr, ok )
2408 infot = 4
2409 CALL dgemmtr( 'U', 'T', 'N', -1, 0, alpha, a, 1, b, 1, beta, c,
2410 $ 1 )
2411 CALL chkxer( srnamt, infot, nout, lerr, ok )
2412 infot = 4
2413 CALL dgemmtr( 'U', 'T', 'T', -1, 0, alpha, a, 1, b, 1, beta, c,
2414 $ 1 )
2415 CALL chkxer( srnamt, infot, nout, lerr, ok )
2416 infot = 5
2417 CALL dgemmtr( 'U', 'N', 'N', 0, -1, alpha, a, 1, b, 1, beta, c,
2418 $ 1 )
2419 CALL chkxer( srnamt, infot, nout, lerr, ok )
2420 infot = 5
2421 CALL dgemmtr( 'U', 'N', 'T', 0, -1, alpha, a, 1, b, 1, beta, c,
2422 $ 1 )
2423 CALL chkxer( srnamt, infot, nout, lerr, ok )
2424 infot = 5
2425 CALL dgemmtr( 'U', 'T', 'N', 0, -1, alpha, a, 1, b, 1, beta, c,
2426 $ 1 )
2427 CALL chkxer( srnamt, infot, nout, lerr, ok )
2428 infot = 5
2429 CALL dgemmtr( 'U', 'T', 'T', 0, -1, alpha, a, 1, b, 1, beta, c,
2430 $ 1 )
2431 CALL chkxer( srnamt, infot, nout, lerr, ok )
2432 infot = 8
2433 CALL dgemmtr( 'U', 'N', 'N', 2, 0, alpha, a, 1, b, 2, beta, c,
2434 $ 2 )
2435 CALL chkxer( srnamt, infot, nout, lerr, ok )
2436 infot = 8
2437 CALL dgemmtr( 'U', 'N', 'T', 2, 0, alpha, a, 1, b, 2, beta, c, 2 )
2438 CALL chkxer( srnamt, infot, nout, lerr, ok )
2439 infot = 10
2440 CALL dgemmtr( 'U', 'N', 'N', 0, 2, alpha, a, 1, b, 1, beta, c, 1 )
2441 CALL chkxer( srnamt, infot, nout, lerr, ok )
2442 infot = 10
2443 CALL dgemmtr( 'U', 'T', 'N', 0, 2, alpha, a, 2, b, 1, beta, c, 1 )
2444 CALL chkxer( srnamt, infot, nout, lerr, ok )
2445 infot = 10
2446 CALL dgemmtr( 'U', 'N', 'T', 2, 0, alpha, a, 2, b, 1, beta, c, 1 )
2447 CALL chkxer( srnamt, infot, nout, lerr, ok )
2448 infot = 10
2449 CALL dgemmtr( 'U', 'T', 'T', 2, 0, alpha, a, 2, b, 1, beta, c, 1 )
2450 CALL chkxer( srnamt, infot, nout, lerr, ok )
2451 infot = 13
2452 CALL dgemmtr( 'U', 'N', 'N', 2, 0, alpha, a, 2, b, 1, beta, c, 1 )
2453 CALL chkxer( srnamt, infot, nout, lerr, ok )
2454 infot = 13
2455 CALL dgemmtr( 'U', 'N', 'T', 2, 0, alpha, a, 2, b, 2, beta, c, 1 )
2456 CALL chkxer( srnamt, infot, nout, lerr, ok )
2457 infot = 13
2458 CALL dgemmtr( 'U', 'T', 'N', 2, 0, alpha, a, 2, b, 1, beta, c, 1 )
2459 CALL chkxer( srnamt, infot, nout, lerr, ok )
2460 infot = 13
2461 CALL dgemmtr( 'U', 'T', 'T', 2, 0, alpha, a, 2, b, 2, beta, c, 1 )
2462 CALL chkxer( srnamt, infot, nout, lerr, ok )
2463*
2464 80 IF( ok )THEN
2465 WRITE( nout, fmt = 9999 )srnamt
2466 ELSE
2467 WRITE( nout, fmt = 9998 )srnamt
2468 END IF
2469 RETURN
2470*
2471 9999 FORMAT( ' ', a6, ' PASSED THE TESTS OF ERROR-EXITS' )
2472 9998 FORMAT( ' ******* ', a6, ' FAILED THE TESTS OF ERROR-EXITS *****',
2473 $ '**' )
2474*
2475* End of DCHKE
2476*
2477 END
2478 SUBROUTINE dmake( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
2479 $ TRANSL )
2480*
2481* Generates values for an M by N matrix A.
2482* Stores the values in the array AA in the data structure required
2483* by the routine, with unwanted elements set to rogue value.
2484*
2485* TYPE is 'GE', 'SY' or 'TR'.
2486*
2487* Auxiliary routine for test program for Level 3 Blas.
2488*
2489* -- Written on 8-February-1989.
2490* Jack Dongarra, Argonne National Laboratory.
2491* Iain Duff, AERE Harwell.
2492* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2493* Sven Hammarling, Numerical Algorithms Group Ltd.
2494*
2495* .. Parameters ..
2496 DOUBLE PRECISION ZERO, ONE
2497 PARAMETER ( ZERO = 0.0d0, one = 1.0d0 )
2498 DOUBLE PRECISION ROGUE
2499 PARAMETER ( ROGUE = -1.0d10 )
2500* .. Scalar Arguments ..
2501 DOUBLE PRECISION TRANSL
2502 INTEGER LDA, M, N, NMAX
2503 LOGICAL RESET
2504 CHARACTER*1 DIAG, UPLO
2505 CHARACTER*2 TYPE
2506* .. Array Arguments ..
2507 DOUBLE PRECISION A( NMAX, * ), AA( * )
2508* .. Local Scalars ..
2509 INTEGER I, IBEG, IEND, J
2510 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2511* .. External Functions ..
2512 DOUBLE PRECISION DBEG
2513 EXTERNAL dbeg
2514* .. Executable Statements ..
2515 gen = type.EQ.'GE'
2516 sym = type.EQ.'SY'
2517 tri = type.EQ.'TR'
2518 upper = ( sym.OR.tri ).AND.uplo.EQ.'U'
2519 lower = ( sym.OR.tri ).AND.uplo.EQ.'L'
2520 unit = tri.AND.diag.EQ.'U'
2521*
2522* Generate data in array A.
2523*
2524 DO 20 j = 1, n
2525 DO 10 i = 1, m
2526 IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
2527 $ THEN
2528 a( i, j ) = dbeg( reset ) + transl
2529 IF( i.NE.j )THEN
2530* Set some elements to zero
2531 IF( n.GT.3.AND.j.EQ.n/2 )
2532 $ a( i, j ) = zero
2533 IF( sym )THEN
2534 a( j, i ) = a( i, j )
2535 ELSE IF( tri )THEN
2536 a( j, i ) = zero
2537 END IF
2538 END IF
2539 END IF
2540 10 CONTINUE
2541 IF( tri )
2542 $ a( j, j ) = a( j, j ) + one
2543 IF( unit )
2544 $ a( j, j ) = one
2545 20 CONTINUE
2546*
2547* Store elements in array AS in data structure required by routine.
2548*
2549 IF( type.EQ.'GE' )THEN
2550 DO 50 j = 1, n
2551 DO 30 i = 1, m
2552 aa( i + ( j - 1 )*lda ) = a( i, j )
2553 30 CONTINUE
2554 DO 40 i = m + 1, lda
2555 aa( i + ( j - 1 )*lda ) = rogue
2556 40 CONTINUE
2557 50 CONTINUE
2558 ELSE IF( type.EQ.'SY'.OR.type.EQ.'TR' )THEN
2559 DO 90 j = 1, n
2560 IF( upper )THEN
2561 ibeg = 1
2562 IF( unit )THEN
2563 iend = j - 1
2564 ELSE
2565 iend = j
2566 END IF
2567 ELSE
2568 IF( unit )THEN
2569 ibeg = j + 1
2570 ELSE
2571 ibeg = j
2572 END IF
2573 iend = n
2574 END IF
2575 DO 60 i = 1, ibeg - 1
2576 aa( i + ( j - 1 )*lda ) = rogue
2577 60 CONTINUE
2578 DO 70 i = ibeg, iend
2579 aa( i + ( j - 1 )*lda ) = a( i, j )
2580 70 CONTINUE
2581 DO 80 i = iend + 1, lda
2582 aa( i + ( j - 1 )*lda ) = rogue
2583 80 CONTINUE
2584 90 CONTINUE
2585 END IF
2586 RETURN
2587*
2588* End of DMAKE
2589*
2590 END
2591 SUBROUTINE dmmch( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
2592 $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
2593 $ NOUT, MV )
2594*
2595* Checks the results of the computational tests.
2596*
2597* Auxiliary routine for test program for Level 3 Blas.
2598*
2599* -- Written on 8-February-1989.
2600* Jack Dongarra, Argonne National Laboratory.
2601* Iain Duff, AERE Harwell.
2602* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2603* Sven Hammarling, Numerical Algorithms Group Ltd.
2604*
2605* .. Parameters ..
2606 DOUBLE PRECISION ZERO, ONE
2607 PARAMETER ( ZERO = 0.0d0, one = 1.0d0 )
2608* .. Scalar Arguments ..
2609 DOUBLE PRECISION ALPHA, BETA, EPS, ERR
2610 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
2611 LOGICAL FATAL, MV
2612 CHARACTER*1 TRANSA, TRANSB
2613* .. Array Arguments ..
2614 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
2615 $ CC( LDCC, * ), CT( * ), G( * )
2616* .. Local Scalars ..
2617 DOUBLE PRECISION ERRI
2618 INTEGER I, J, K
2619 LOGICAL TRANA, TRANB
2620* .. Intrinsic Functions ..
2621 INTRINSIC abs, max, sqrt
2622* .. Executable Statements ..
2623 trana = transa.EQ.'T'.OR.transa.EQ.'C'
2624 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
2625*
2626* Compute expected result, one column at a time, in CT using data
2627* in A, B and C.
2628* Compute gauges in G.
2629*
2630 DO 120 j = 1, n
2631*
2632 DO 10 i = 1, m
2633 ct( i ) = zero
2634 g( i ) = zero
2635 10 CONTINUE
2636 IF( .NOT.trana.AND..NOT.tranb )THEN
2637 DO 30 k = 1, kk
2638 DO 20 i = 1, m
2639 ct( i ) = ct( i ) + a( i, k )*b( k, j )
2640 g( i ) = g( i ) + abs( a( i, k ) )*abs( b( k, j ) )
2641 20 CONTINUE
2642 30 CONTINUE
2643 ELSE IF( trana.AND..NOT.tranb )THEN
2644 DO 50 k = 1, kk
2645 DO 40 i = 1, m
2646 ct( i ) = ct( i ) + a( k, i )*b( k, j )
2647 g( i ) = g( i ) + abs( a( k, i ) )*abs( b( k, j ) )
2648 40 CONTINUE
2649 50 CONTINUE
2650 ELSE IF( .NOT.trana.AND.tranb )THEN
2651 DO 70 k = 1, kk
2652 DO 60 i = 1, m
2653 ct( i ) = ct( i ) + a( i, k )*b( j, k )
2654 g( i ) = g( i ) + abs( a( i, k ) )*abs( b( j, k ) )
2655 60 CONTINUE
2656 70 CONTINUE
2657 ELSE IF( trana.AND.tranb )THEN
2658 DO 90 k = 1, kk
2659 DO 80 i = 1, m
2660 ct( i ) = ct( i ) + a( k, i )*b( j, k )
2661 g( i ) = g( i ) + abs( a( k, i ) )*abs( b( j, k ) )
2662 80 CONTINUE
2663 90 CONTINUE
2664 END IF
2665 DO 100 i = 1, m
2666 ct( i ) = alpha*ct( i ) + beta*c( i, j )
2667 g( i ) = abs( alpha )*g( i ) + abs( beta )*abs( c( i, j ) )
2668 100 CONTINUE
2669*
2670* Compute the error ratio for this result.
2671*
2672 err = zero
2673 DO 110 i = 1, m
2674 erri = abs( ct( i ) - cc( i, j ) )/eps
2675 IF( g( i ).NE.zero )
2676 $ erri = erri/g( i )
2677 err = max( err, erri )
2678 IF( err*sqrt( eps ).GE.one )
2679 $ GO TO 130
2680 110 CONTINUE
2681*
2682 120 CONTINUE
2683*
2684* If the loop completes, all results are at least half accurate.
2685 GO TO 150
2686*
2687* Report fatal error.
2688*
2689 130 fatal = .true.
2690 WRITE( nout, fmt = 9999 )
2691 DO 140 i = 1, m
2692 IF( mv )THEN
2693 WRITE( nout, fmt = 9998 )i, ct( i ), cc( i, j )
2694 ELSE
2695 WRITE( nout, fmt = 9998 )i, cc( i, j ), ct( i )
2696 END IF
2697 140 CONTINUE
2698 IF( n.GT.1 )
2699 $ WRITE( nout, fmt = 9997 )j
2700*
2701 150 CONTINUE
2702 RETURN
2703*
2704 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2705 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2706 $ 'TED RESULT' )
2707 9998 FORMAT( 1x, i7, 2g18.6 )
2708 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2709*
2710* End of DMMCH
2711*
2712 END
2713 LOGICAL FUNCTION lde( RI, RJ, LR )
2714*
2715* Tests if two arrays are identical.
2716*
2717* Auxiliary routine for test program for Level 3 Blas.
2718*
2719* -- Written on 8-February-1989.
2720* Jack Dongarra, Argonne National Laboratory.
2721* Iain Duff, AERE Harwell.
2722* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2723* Sven Hammarling, Numerical Algorithms Group Ltd.
2724*
2725* .. Scalar Arguments ..
2726 INTEGER lr
2727* .. Array Arguments ..
2728 DOUBLE PRECISION ri( * ), rj( * )
2729* .. Local Scalars ..
2730 INTEGER i
2731* .. Executable Statements ..
2732 do 10 i = 1, lr
2733 IF( ri( i ).NE.rj( i ) )
2734 $ GO TO 20
2735 10 CONTINUE
2736 lde = .true.
2737 GO TO 30
2738 20 CONTINUE
2739 lde = .false.
2740 30 RETURN
2741*
2742* End of LDE
2743*
2744 END
2745 LOGICAL FUNCTION lderes( TYPE, UPLO, M, N, AA, AS, LDA )
2746*
2747* Tests if selected elements in two arrays are equal.
2748*
2749* TYPE is 'GE' or 'SY'.
2750*
2751* Auxiliary routine for test program for Level 3 Blas.
2752*
2753* -- Written on 8-February-1989.
2754* Jack Dongarra, Argonne National Laboratory.
2755* Iain Duff, AERE Harwell.
2756* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2757* Sven Hammarling, Numerical Algorithms Group Ltd.
2758*
2759* .. Scalar Arguments ..
2760 INTEGER lda, m, n
2761 CHARACTER*1 uplo
2762 CHARACTER*2 type
2763* .. Array Arguments ..
2764 DOUBLE PRECISION aa( lda, * ), as( lda, * )
2765* .. Local Scalars ..
2766 INTEGER i, ibeg, iend, j
2767 LOGICAL upper
2768* .. Executable Statements ..
2769 upper = uplo.EQ.'U'
2770 IF( type.EQ.'GE' )THEN
2771 DO 20 j = 1, n
2772 DO 10 i = m + 1, lda
2773 IF( aa( i, j ).NE.as( i, j ) )
2774 $ GO TO 70
2775 10 CONTINUE
2776 20 CONTINUE
2777 ELSE IF( type.EQ.'SY' )THEN
2778 DO 50 j = 1, n
2779 IF( upper )THEN
2780 ibeg = 1
2781 iend = j
2782 ELSE
2783 ibeg = j
2784 iend = n
2785 END IF
2786 DO 30 i = 1, ibeg - 1
2787 IF( aa( i, j ).NE.as( i, j ) )
2788 $ GO TO 70
2789 30 CONTINUE
2790 DO 40 i = iend + 1, lda
2791 IF( aa( i, j ).NE.as( i, j ) )
2792 $ GO TO 70
2793 40 CONTINUE
2794 50 CONTINUE
2795 END IF
2796*
2797 lderes = .true.
2798 GO TO 80
2799 70 CONTINUE
2800 lderes = .false.
2801 80 RETURN
2802*
2803* End of LDERES
2804*
2805 END
2806 DOUBLE PRECISION FUNCTION dbeg( RESET )
2807*
2808* Generates random numbers uniformly distributed between -0.5 and 0.5.
2809*
2810* Auxiliary routine for test program for Level 3 Blas.
2811*
2812* -- Written on 8-February-1989.
2813* Jack Dongarra, Argonne National Laboratory.
2814* Iain Duff, AERE Harwell.
2815* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2816* Sven Hammarling, Numerical Algorithms Group Ltd.
2817*
2818* .. Scalar Arguments ..
2819 LOGICAL reset
2820* .. Local Scalars ..
2821 INTEGER i, ic, mi
2822* .. Save statement ..
2823 SAVE i, ic, mi
2824* .. Executable Statements ..
2825 if( reset )then
2826* Initialize local variables.
2827 mi = 891
2828 i = 7
2829 ic = 0
2830 reset = .false.
2831 END IF
2832*
2833* The sequence of values of I is bounded between 1 and 999.
2834* If initial I = 1,2,3,6,7 or 9, the period will be 50.
2835* If initial I = 4 or 8, the period will be 25.
2836* If initial I = 5, the period will be 10.
2837* IC is used to break up the period by skipping 1 value of I in 6.
2838*
2839 ic = ic + 1
2840 10 i = i*mi
2841 i = i - 1000*( i/1000 )
2842 IF( ic.GE.5 )THEN
2843 ic = 0
2844 GO TO 10
2845 END IF
2846 dbeg = ( i - 500 )/1001.0d0
2847 RETURN
2848*
2849* End of DBEG
2850*
2851 END
2852 DOUBLE PRECISION FUNCTION ddiff( X, Y )
2853*
2854* Auxiliary routine for test program for Level 3 Blas.
2855*
2856* -- Written on 8-February-1989.
2857* Jack Dongarra, Argonne National Laboratory.
2858* Iain Duff, AERE Harwell.
2859* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2860* Sven Hammarling, Numerical Algorithms Group Ltd.
2861*
2862* .. Scalar Arguments ..
2863 DOUBLE PRECISION x, y
2864* .. Executable Statements ..
2865 ddiff = x - y
2866 RETURN
2867*
2868* End of DDIFF
2869*
2870 END
2871 SUBROUTINE chkxer( SRNAMT, INFOT, NOUT, LERR, OK )
2872*
2873* Tests whether XERBLA has detected an error when it should.
2874*
2875* Auxiliary routine for test program for Level 3 Blas.
2876*
2877* -- Written on 8-February-1989.
2878* Jack Dongarra, Argonne National Laboratory.
2879* Iain Duff, AERE Harwell.
2880* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2881* Sven Hammarling, Numerical Algorithms Group Ltd.
2882*
2883* .. Scalar Arguments ..
2884 INTEGER INFOT, NOUT
2885 LOGICAL LERR, OK
2886 CHARACTER*7 SRNAMT
2887* .. Executable Statements ..
2888 IF( .NOT.LERR )THEN
2889 WRITE( NOUT, FMT = 9999 )infot, srnamt
2890 ok = .false.
2891 END IF
2892 lerr = .false.
2893 RETURN
2894*
2895 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', i2, ' NOT D',
2896 $ 'ETECTED BY ', a6, ' *****' )
2897*
2898* End of CHKXER
2899*
2900 END
2901 SUBROUTINE xerbla( SRNAME, INFO )
2902*
2903* This is a special version of XERBLA to be used only as part of
2904* the test program for testing error exits from the Level 3 BLAS
2905* routines.
2906*
2907* XERBLA is an error handler for the Level 3 BLAS routines.
2908*
2909* It is called by the Level 3 BLAS routines if an input parameter is
2910* invalid.
2911*
2912* Auxiliary routine for test program for Level 3 Blas.
2913*
2914* -- Written on 8-February-1989.
2915* Jack Dongarra, Argonne National Laboratory.
2916* Iain Duff, AERE Harwell.
2917* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2918* Sven Hammarling, Numerical Algorithms Group Ltd.
2919*
2920* .. Scalar Arguments ..
2921 INTEGER INFO
2922 CHARACTER*(*) SRNAME
2923* .. Scalars in Common ..
2924 INTEGER INFOT, NOUT
2925 LOGICAL LERR, OK
2926 CHARACTER*7 SRNAMT
2927* .. Common blocks ..
2928 COMMON /INFOC/INFOT, NOUT, OK, LERR
2929 COMMON /SRNAMC/SRNAMT
2930* .. Executable Statements ..
2931 LERR = .true.
2932 IF( info.NE.infot )THEN
2933 IF( infot.NE.0 )THEN
2934 WRITE( nout, fmt = 9999 )info, infot
2935 ELSE
2936 WRITE( nout, fmt = 9997 )info
2937 END IF
2938 ok = .false.
2939 END IF
2940 IF( srname.NE.srnamt )THEN
2941 WRITE( nout, fmt = 9998 )srname, srnamt
2942 ok = .false.
2943 END IF
2944 RETURN
2945*
2946 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', i6, ' INSTEAD',
2947 $ ' OF ', i2, ' *******' )
2948 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', a6, ' INSTE',
2949 $ 'AD OF ', a6, ' *******' )
2950 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', i6,
2951 $ ' *******' )
2952*
2953* End of XERBLA
2954*
2955 END
2956
2957 SUBROUTINE dchk6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
2958 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
2959 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
2960*
2961* Tests DGEMMTR.
2962*
2963* Auxiliary routine for test program for Level 3 Blas.
2964*
2965* -- Written on 19-July-2023.
2966* Martin Koehler, MPI Magdeburg
2967*
2968* .. Parameters ..
2969 DOUBLE PRECISION ZERO
2970 parameter( zero = 0.0d0 )
2971* .. Scalar Arguments ..
2972 DOUBLE PRECISION EPS, THRESH
2973 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
2974 LOGICAL FATAL, REWI, TRACE
2975 CHARACTER*7 SNAME
2976* .. Array Arguments ..
2977 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2978 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
2979 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
2980 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
2981 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
2982 INTEGER IDIM( NIDIM )
2983* .. Local Scalars ..
2984 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
2985 INTEGER I, IA, IB, ICA, ICB, IK, IN, K, KS, LAA,
2986 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS,
2987 $ ma, mb, n, na, nargs, nb, nc, ns, is
2988 LOGICAL NULL, RESET, SAME, TRANA, TRANB
2989 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB, UPLO, UPLOS
2990 CHARACTER*3 ICH
2991 CHARACTER*2 ISHAPE
2992* .. Local Arrays ..
2993 LOGICAL ISAME( 13 )
2994* .. External Functions ..
2995 LOGICAL LDE, LDERES
2996 EXTERNAL LDE, LDERES
2997* .. External Subroutines ..
2998 EXTERNAL dgemmtr, dmake, dmmtch
2999* .. Intrinsic Functions ..
3000 INTRINSIC max
3001* .. Scalars in Common ..
3002 INTEGER INFOT, NOUTC
3003 LOGICAL LERR, OK
3004* .. Common blocks ..
3005 COMMON /infoc/infot, noutc, ok, lerr
3006* .. Data statements ..
3007 DATA ich/'NTC'/
3008 DATA ishape/'UL'/
3009* .. Executable Statements ..
3010*
3011 nargs = 13
3012 nc = 0
3013 reset = .true.
3014 errmax = zero
3015*
3016 DO 100 in = 1, nidim
3017 n = idim( in )
3018* Set LDC to 1 more than minimum value if room.
3019 ldc = n
3020 IF( ldc.LT.nmax )
3021 $ ldc = ldc + 1
3022* Skip tests if not enough room.
3023 IF( ldc.GT.nmax )
3024 $ GO TO 100
3025 lcc = ldc*n
3026 null = n.LE.0
3027*
3028 DO 90 ik = 1, nidim
3029 k = idim( ik )
3030*
3031 DO 80 ica = 1, 3
3032 transa = ich( ica: ica )
3033 trana = transa.EQ.'T'.OR.transa.EQ.'C'
3034*
3035 IF( trana )THEN
3036 ma = k
3037 na = n
3038 ELSE
3039 ma = n
3040 na = k
3041 END IF
3042* Set LDA to 1 more than minimum value if room.
3043 lda = ma
3044 IF( lda.LT.nmax )
3045 $ lda = lda + 1
3046* Skip tests if not enough room.
3047 IF( lda.GT.nmax )
3048 $ GO TO 80
3049 laa = lda*na
3050*
3051* Generate the matrix A.
3052*
3053 CALL dmake( 'GE', ' ', ' ', ma, na, a, nmax, aa, lda,
3054 $ reset, zero )
3055*
3056 DO 70 icb = 1, 3
3057 transb = ich( icb: icb )
3058 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
3059*
3060 IF( tranb )THEN
3061 mb = n
3062 nb = k
3063 ELSE
3064 mb = k
3065 nb = n
3066 END IF
3067* Set LDB to 1 more than minimum value if room.
3068 ldb = mb
3069 IF( ldb.LT.nmax )
3070 $ ldb = ldb + 1
3071* Skip tests if not enough room.
3072 IF( ldb.GT.nmax )
3073 $ GO TO 70
3074 lbb = ldb*nb
3075*
3076* Generate the matrix B.
3077*
3078 CALL dmake( 'GE', ' ', ' ', mb, nb, b, nmax, bb,
3079 $ ldb, reset, zero )
3080*
3081 DO 60 ia = 1, nalf
3082 alpha = alf( ia )
3083*
3084 DO 50 ib = 1, nbet
3085 beta = bet( ib )
3086
3087 DO 45 is = 1, 2
3088 uplo = ishape( is: is )
3089
3090*
3091* Generate the matrix C.
3092*
3093 CALL dmake( 'GE', uplo, ' ', n, n, c,
3094 $ nmax, cc, ldc, reset, zero )
3095*
3096 nc = nc + 1
3097*
3098* Save every datum before calling the
3099* subroutine.
3100*
3101 uplos = uplo
3102 tranas = transa
3103 tranbs = transb
3104 ns = n
3105 ks = k
3106 als = alpha
3107 DO 10 i = 1, laa
3108 as( i ) = aa( i )
3109 10 CONTINUE
3110 ldas = lda
3111 DO 20 i = 1, lbb
3112 bs( i ) = bb( i )
3113 20 CONTINUE
3114 ldbs = ldb
3115 bls = beta
3116 DO 30 i = 1, lcc
3117 cs( i ) = cc( i )
3118 30 CONTINUE
3119 ldcs = ldc
3120*
3121* Call the subroutine.
3122*
3123 IF( trace )
3124 $ WRITE( ntra, fmt = 9995 )nc, sname,
3125 $ uplo, transa, transb, n, k, alpha, lda,
3126 $ ldb, beta, ldc
3127 IF( rewi )
3128 $ rewind ntra
3129 CALL dgemmtr( uplo, transa, transb, n,
3130 $ k, alpha, aa, lda, bb, ldb,
3131 $ beta, cc, ldc )
3132*
3133* Check if error-exit was taken incorrectly.
3134*
3135 IF( .NOT.ok )THEN
3136 WRITE( nout, fmt = 9994 )
3137 fatal = .true.
3138 GO TO 120
3139 END IF
3140*
3141* See what data changed inside subroutines.
3142*
3143 isame( 1 ) = uplo.EQ.uplos
3144 isame( 2 ) = transa.EQ.tranas
3145 isame( 3 ) = transb.EQ.tranbs
3146 isame( 4 ) = ns.EQ.n
3147 isame( 5 ) = ks.EQ.k
3148 isame( 6 ) = als.EQ.alpha
3149 isame( 7 ) = lde( as, aa, laa )
3150 isame( 8 ) = ldas.EQ.lda
3151 isame( 9 ) = lde( bs, bb, lbb )
3152 isame( 10 ) = ldbs.EQ.ldb
3153 isame( 11 ) = bls.EQ.beta
3154 IF( null )THEN
3155 isame( 12 ) = lde( cs, cc, lcc )
3156 ELSE
3157 isame( 12 ) = lderes( 'GE', ' ', n, n,
3158 $ cs, cc, ldc )
3159 END IF
3160 isame( 13 ) = ldcs.EQ.ldc
3161*
3162* If data was incorrectly changed, report
3163* and return.
3164*
3165 same = .true.
3166 DO 40 i = 1, nargs
3167 same = same.AND.isame( i )
3168 IF( .NOT.isame( i ) )
3169 $ WRITE( nout, fmt = 9998 )i
3170 40 CONTINUE
3171 IF( .NOT.same )THEN
3172 fatal = .true.
3173 GO TO 120
3174 END IF
3175*
3176 IF( .NOT.null )THEN
3177*
3178* Check the result.
3179*
3180 CALL dmmtch( uplo, transa, transb,
3181 $ n, k,
3182 $ alpha, a, nmax, b, nmax, beta,
3183 $ c, nmax, ct, g, cc, ldc, eps,
3184 $ err, fatal, nout, .true. )
3185 errmax = max( errmax, err )
3186* If got really bad answer, report and
3187* return.
3188 IF( fatal )
3189 $ GO TO 120
3190 END IF
3191*
3192 45 CONTINUE
3193*
3194 50 CONTINUE
3195*
3196 60 CONTINUE
3197*
3198 70 CONTINUE
3199*
3200 80 CONTINUE
3201*
3202 90 CONTINUE
3203*
3204 100 CONTINUE
3205*
3206*
3207* Report result.
3208*
3209 IF( errmax.LT.thresh )THEN
3210 WRITE( nout, fmt = 9999 )sname, nc
3211 ELSE
3212 WRITE( nout, fmt = 9997 )sname, nc, errmax
3213 END IF
3214 GO TO 130
3215*
3216 120 CONTINUE
3217 WRITE( nout, fmt = 9996 )sname
3218 WRITE( nout, fmt = 9995 )nc, sname, uplo, transa, transb, n, k,
3219 $ alpha, lda, ldb, beta, ldc
3220*
3221 130 CONTINUE
3222 RETURN
3223*
3224 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
3225 $ 'S)' )
3226 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
3227 $ 'ANGED INCORRECTLY *******' )
3228 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
3229 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
3230 $ ' - SUSPECT *******' )
3231 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
3232 9995 FORMAT( 1x, i6, ': ', a6, '(''',a1, ''',''',a1, ''',''', a1,''',',
3233 $ 2( i3, ',' ), f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', ',
3234 $ 'C,', i3, ').' )
3235 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
3236 $ '******' )
3237*
3238* End of DCHK6
3239*
3240 END
3241
3242 SUBROUTINE dmmtch( UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA,
3243 $ B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR,
3244 $ FATAL, NOUT, MV )
3245*
3246* Checks the results of the computational tests.
3247*
3248* Auxiliary routine for test program for Level 3 Blas. (DGEMMTR)
3249*
3250* -- Written on 19-July-2023.
3251* Martin Koehler, MPI Magdeburg
3252*
3253* .. Parameters ..
3254 DOUBLE PRECISION ZERO, ONE
3255 PARAMETER ( ZERO = 0.0d0, one = 1.0d0 )
3256* .. Scalar Arguments ..
3257 DOUBLE PRECISION ALPHA, BETA, EPS, ERR
3258 INTEGER KK, LDA, LDB, LDC, LDCC, N, NOUT
3259 LOGICAL FATAL, MV
3260 CHARACTER*1 UPLO, TRANSA, TRANSB
3261* .. Array Arguments ..
3262 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
3263 $ CC( LDCC, * ), CT( * ), G( * )
3264* .. Local Scalars ..
3265 DOUBLE PRECISION ERRI
3266 INTEGER I, J, K, ISTART, ISTOP
3267 LOGICAL TRANA, TRANB, UPPER
3268* .. Intrinsic Functions ..
3269 INTRINSIC ABS, MAX, SQRT
3270* .. Executable Statements ..
3271 upper = uplo.EQ.'U'
3272 trana = transa.EQ.'T'.OR.transa.EQ.'C'
3273 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
3274*
3275* Compute expected result, one column at a time, in CT using data
3276* in A, B and C.
3277* Compute gauges in G.
3278*
3279 istart = 1
3280 istop = n
3281
3282 DO 120 j = 1, n
3283*
3284 IF ( upper ) THEN
3285 istart = 1
3286 istop = j
3287 ELSE
3288 istart = j
3289 istop = n
3290 END IF
3291 DO 10 i = istart, istop
3292 ct( i ) = zero
3293 g( i ) = zero
3294 10 CONTINUE
3295 IF( .NOT.trana.AND..NOT.tranb )THEN
3296 DO 30 k = 1, kk
3297 DO 20 i = istart, istop
3298 ct( i ) = ct( i ) + a( i, k )*b( k, j )
3299 g( i ) = g( i ) + abs( a( i, k ) )*abs( b( k, j ) )
3300 20 CONTINUE
3301 30 CONTINUE
3302 ELSE IF( trana.AND..NOT.tranb )THEN
3303 DO 50 k = 1, kk
3304 DO 40 i = istart, istop
3305 ct( i ) = ct( i ) + a( k, i )*b( k, j )
3306 g( i ) = g( i ) + abs( a( k, i ) )*abs( b( k, j ) )
3307 40 CONTINUE
3308 50 CONTINUE
3309 ELSE IF( .NOT.trana.AND.tranb )THEN
3310 DO 70 k = 1, kk
3311 DO 60 i = istart, istop
3312 ct( i ) = ct( i ) + a( i, k )*b( j, k )
3313 g( i ) = g( i ) + abs( a( i, k ) )*abs( b( j, k ) )
3314 60 CONTINUE
3315 70 CONTINUE
3316 ELSE IF( trana.AND.tranb )THEN
3317 DO 90 k = 1, kk
3318 DO 80 i = istart, istop
3319 ct( i ) = ct( i ) + a( k, i )*b( j, k )
3320 g( i ) = g( i ) + abs( a( k, i ) )*abs( b( j, k ) )
3321 80 CONTINUE
3322 90 CONTINUE
3323 END IF
3324 DO 100 i = istart, istop
3325 ct( i ) = alpha*ct( i ) + beta*c( i, j )
3326 g( i ) = abs( alpha )*g( i ) + abs( beta )*abs( c( i, j ) )
3327 100 CONTINUE
3328*
3329* Compute the error ratio for this result.
3330*
3331 err = zero
3332 DO 110 i = istart, istop
3333 erri = abs( ct( i ) - cc( i, j ) )/eps
3334 IF( g( i ).NE.zero )
3335 $ erri = erri/g( i )
3336 err = max( err, erri )
3337 IF( err*sqrt( eps ).GE.one )
3338 $ GO TO 130
3339 110 CONTINUE
3340*
3341 120 CONTINUE
3342*
3343* If the loop completes, all results are at least half accurate.
3344 GO TO 150
3345*
3346* Report fatal error.
3347*
3348 130 fatal = .true.
3349 WRITE( nout, fmt = 9999 )
3350 DO 140 i = istart, istop
3351 IF( mv )THEN
3352 WRITE( nout, fmt = 9998 )i, ct( i ), cc( i, j )
3353 ELSE
3354 WRITE( nout, fmt = 9998 )i, cc( i, j ), ct( i )
3355 END IF
3356 140 CONTINUE
3357 IF( n.GT.1 )
3358 $ WRITE( nout, fmt = 9997 )j
3359*
3360 150 CONTINUE
3361 RETURN
3362*
3363 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3364 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
3365 $ 'TED RESULT' )
3366 9998 FORMAT( 1x, i7, 2g18.6 )
3367 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
3368*
3369* End of DMMTCH
3370*
3371 END
3372
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3224
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
dchk6
subroutine dchk6(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:2039
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
dchke
subroutine dchke(isnum, srnamt, nout)
Definition dblat2.f:2351
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
dmmtch
subroutine dmmtch(uplo, transa, transb, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition dblat3.f:3245
dblat3
program dblat3
DBLAT3
Definition dblat3.f:82
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:2594
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:188
dgemmtr
subroutine dgemmtr(uplo, transa, transb, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMMTR
Definition dgemmtr.f:191
dsymm
subroutine dsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
DSYMM
Definition dsymm.f:189
dsyr2k
subroutine dsyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DSYR2K
Definition dsyr2k.f:192
dsyrk
subroutine dsyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
DSYRK
Definition dsyrk.f:169
dtrmm
subroutine dtrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRMM
Definition dtrmm.f:177
dtrsm
subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRSM
Definition dtrsm.f:181