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