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