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