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