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