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