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 *
383 10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
384 10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' )
385 10000 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 *
684 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
685 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
686 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
687 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
688 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
689 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
690 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
691 $ ' (', I6, ' CALL', 'S)' )
692 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
693 $ ' (', I6, ' CALL', 'S)' )
694 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
695 $ 'ANGED INCORRECTLY *******' )
696 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
697 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',',
698 $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
699 $ 'C,', I3, ').' )
700 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
701 $ '******' )
702 *
703 * End of 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 *
1001 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1002 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1003 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1004 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1005 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1006 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1007 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1008 $ ' (', I6, ' CALL', 'S)' )
1009 10000 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 IF( LDB.LT.NMAX )
1130 $ LDB = LDB + 1
1131 * Skip tests if not enough room.
1132 IF( LDB.GT.NMAX )
1133 $ GO TO 130
1134 LBB = LDB*N
1135 NULL = M.LE.0.OR.N.LE.0
1136 *
1137 DO 120 ICS = 1, 2
1138 SIDE = ICHS( ICS: ICS )
1139 LEFT = SIDE.EQ.'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 IF( LDA.LT.NMAX )
1148 $ LDA = LDA + 1
1149 * Skip tests if not enough room.
1150 IF( LDA.GT.NMAX )
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 IF( SNAME( 10: 11 ).EQ.'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 ELSE IF( SNAME( 10: 11 ).EQ.'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 IF( .NOT.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 ISAME( 1 ) = SIDES.EQ.SIDE
1232 ISAME( 2 ) = UPLOS.EQ.UPLO
1233 ISAME( 3 ) = TRANAS.EQ.TRANSA
1234 ISAME( 4 ) = DIAGS.EQ.DIAG
1235 ISAME( 5 ) = MS.EQ.M
1236 ISAME( 6 ) = NS.EQ.N
1237 ISAME( 7 ) = ALS.EQ.ALPHA
1238 ISAME( 8 ) = LSE( AS, AA, LAA )
1239 ISAME( 9 ) = LDAS.EQ.LDA
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 ISAME( 11 ) = LDBS.EQ.LDB
1247 *
1248 * If data was incorrectly changed, report and
1249 * return.
1250 *
1251 SAME = .TRUE.
1252 DO 50 I = 1, NARGS
1253 SAME = SAME.AND.ISAME( I )
1254 IF( .NOT.ISAME( I ) )
1255 $ WRITE( NOUT, FMT = 9998 )I+1
1256 50 CONTINUE
1257 IF( .NOT.SAME )THEN
1258 FATAL = .TRUE.
1259 GO TO 150
1260 END IF
1261 *
1262 IF( .NOT.NULL )THEN
1263 IF( SNAME( 10: 11 ).EQ.'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 ELSE IF( SNAME( 10: 11 ).EQ.'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 IF( ERRMAX.LT.THRESH )THEN
1332 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1333 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1334 ELSE
1335 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1336 IF ( IORDER.EQ.1) 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 CALL SPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG,
1343 $ M, N, ALPHA, LDA, LDB)
1344 *
1345 160 CONTINUE
1346 RETURN
1347 *
1348 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1349 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1350 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1351 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1352 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1353 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1354 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1355 $ ' (', I6, ' CALL', 'S)' )
1356 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1357 $ ' (', I6, ' CALL', 'S)' )
1358 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1359 $ 'ANGED INCORRECTLY *******' )
1360 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
1361 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ),
1362 $ F4.1, ', A,', I3, ', B,', I3, ') .' )
1363 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1364 $ '******' )
1365 *
1366 * End of SCHK3.
1367 *
1368 END
1369 *
1370 SUBROUTINE SPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA,
1371 $ DIAG, M, N, ALPHA, LDA, LDB)
1372 INTEGER NOUT, NC, IORDER, M, N, LDA, LDB
1373 REAL ALPHA
1374 CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
1375 CHARACTER*12 SNAME
1376 CHARACTER*14 CRC, CS, CU, CA, CD
1377
1378 IF (SIDE.EQ.'L')THEN
1379 CS = ' CblasLeft'
1380 ELSE
1381 CS = ' CblasRight'
1382 END IF
1383 IF (UPLO.EQ.'U')THEN
1384 CU = ' CblasUpper'
1385 ELSE
1386 CU = ' CblasLower'
1387 END IF
1388 IF (TRANSA.EQ.'N')THEN
1389 CA = ' CblasNoTrans'
1390 ELSE IF (TRANSA.EQ.'T')THEN
1391 CA = ' CblasTrans'
1392 ELSE
1393 CA = 'CblasConjTrans'
1394 END IF
1395 IF (DIAG.EQ.'N')THEN
1396 CD = ' CblasNonUnit'
1397 ELSE
1398 CD = ' CblasUnit'
1399 END IF
1400 IF (IORDER.EQ.1)THEN
1401 CRC = 'CblasRowMajor'
1402 ELSE
1403 CRC = 'CblasColMajor'
1404 END IF
1405 WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
1406 WRITE(NOUT, FMT = 9994)CA, CD, M, N, ALPHA, LDA, LDB
1407
1408 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
1409 9994 FORMAT( 22X, 2( A14, ',') , 2( I3, ',' ),
1410 $ F4.1, ', A,', I3, ', B,', I3, ').' )
1411 END
1412 *
1413 SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1414 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1415 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G,
1416 $ IORDER )
1417 *
1418 * Tests SSYRK.
1419 *
1420 * Auxiliary routine for test program for Level 3 Blas.
1421 *
1422 * -- Written on 8-February-1989.
1423 * Jack Dongarra, Argonne National Laboratory.
1424 * Iain Duff, AERE Harwell.
1425 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1426 * Sven Hammarling, Numerical Algorithms Group Ltd.
1427 *
1428 * .. Parameters ..
1429 REAL ZERO
1430 PARAMETER ( ZERO = 0.0 )
1431 * .. Scalar Arguments ..
1432 REAL EPS, THRESH
1433 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1434 LOGICAL FATAL, REWI, TRACE
1435 CHARACTER*12 SNAME
1436 * .. Array Arguments ..
1437 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1438 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1439 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
1440 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
1441 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
1442 INTEGER IDIM( NIDIM )
1443 * .. Local Scalars ..
1444 REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1445 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1446 $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1447 $ NARGS, NC, NS
1448 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1449 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1450 CHARACTER*2 ICHU
1451 CHARACTER*3 ICHT
1452 * .. Local Arrays ..
1453 LOGICAL ISAME( 13 )
1454 * .. External Functions ..
1455 LOGICAL LSE, LSERES
1456 EXTERNAL LSE, LSERES
1457 * .. External Subroutines ..
1458 EXTERNAL SMAKE, SMMCH, CSSYRK
1459 * .. Intrinsic Functions ..
1460 INTRINSIC MAX
1461 * .. Scalars in Common ..
1462 INTEGER INFOT, NOUTC
1463 LOGICAL OK
1464 * .. Common blocks ..
1465 COMMON /INFOC/INFOT, NOUTC, OK
1466 * .. Data statements ..
1467 DATA ICHT/'NTC'/, ICHU/'UL'/
1468 * .. Executable Statements ..
1469 *
1470 NARGS = 10
1471 NC = 0
1472 RESET = .TRUE.
1473 ERRMAX = ZERO
1474 *
1475 DO 100 IN = 1, NIDIM
1476 N = IDIM( IN )
1477 * Set LDC to 1 more than minimum value if room.
1478 LDC = N
1479 IF( LDC.LT.NMAX )
1480 $ LDC = LDC + 1
1481 * Skip tests if not enough room.
1482 IF( LDC.GT.NMAX )
1483 $ GO TO 100
1484 LCC = LDC*N
1485 NULL = N.LE.0
1486 *
1487 DO 90 IK = 1, NIDIM
1488 K = IDIM( IK )
1489 *
1490 DO 80 ICT = 1, 3
1491 TRANS = ICHT( ICT: ICT )
1492 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
1493 IF( TRAN )THEN
1494 MA = K
1495 NA = N
1496 ELSE
1497 MA = N
1498 NA = K
1499 END IF
1500 * Set LDA to 1 more than minimum value if room.
1501 LDA = MA
1502 IF( LDA.LT.NMAX )
1503 $ LDA = LDA + 1
1504 * Skip tests if not enough room.
1505 IF( LDA.GT.NMAX )
1506 $ GO TO 80
1507 LAA = LDA*NA
1508 *
1509 * Generate the matrix A.
1510 *
1511 CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
1512 $ RESET, ZERO )
1513 *
1514 DO 70 ICU = 1, 2
1515 UPLO = ICHU( ICU: ICU )
1516 UPPER = UPLO.EQ.'U'
1517 *
1518 DO 60 IA = 1, NALF
1519 ALPHA = ALF( IA )
1520 *
1521 DO 50 IB = 1, NBET
1522 BETA = BET( IB )
1523 *
1524 * Generate the matrix C.
1525 *
1526 CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
1527 $ LDC, RESET, ZERO )
1528 *
1529 NC = NC + 1
1530 *
1531 * Save every datum before calling the subroutine.
1532 *
1533 UPLOS = UPLO
1534 TRANSS = TRANS
1535 NS = N
1536 KS = K
1537 ALS = ALPHA
1538 DO 10 I = 1, LAA
1539 AS( I ) = AA( I )
1540 10 CONTINUE
1541 LDAS = LDA
1542 BETS = BETA
1543 DO 20 I = 1, LCC
1544 CS( I ) = CC( I )
1545 20 CONTINUE
1546 LDCS = LDC
1547 *
1548 * Call the subroutine.
1549 *
1550 IF( TRACE )
1551 $ CALL SPRCN4( NTRA, NC, SNAME, IORDER, UPLO,
1552 $ TRANS, N, K, ALPHA, LDA, BETA, LDC)
1553 IF( REWI )
1554 $ REWIND NTRA
1555 CALL CSSYRK( IORDER, UPLO, TRANS, N, K, ALPHA,
1556 $ AA, LDA, BETA, CC, LDC )
1557 *
1558 * Check if error-exit was taken incorrectly.
1559 *
1560 IF( .NOT.OK )THEN
1561 WRITE( NOUT, FMT = 9993 )
1562 FATAL = .TRUE.
1563 GO TO 120
1564 END IF
1565 *
1566 * See what data changed inside subroutines.
1567 *
1568 ISAME( 1 ) = UPLOS.EQ.UPLO
1569 ISAME( 2 ) = TRANSS.EQ.TRANS
1570 ISAME( 3 ) = NS.EQ.N
1571 ISAME( 4 ) = KS.EQ.K
1572 ISAME( 5 ) = ALS.EQ.ALPHA
1573 ISAME( 6 ) = LSE( AS, AA, LAA )
1574 ISAME( 7 ) = LDAS.EQ.LDA
1575 ISAME( 8 ) = BETS.EQ.BETA
1576 IF( NULL )THEN
1577 ISAME( 9 ) = LSE( CS, CC, LCC )
1578 ELSE
1579 ISAME( 9 ) = LSERES( 'SY', UPLO, N, N, CS,
1580 $ CC, LDC )
1581 END IF
1582 ISAME( 10 ) = LDCS.EQ.LDC
1583 *
1584 * If data was incorrectly changed, report and
1585 * return.
1586 *
1587 SAME = .TRUE.
1588 DO 30 I = 1, NARGS
1589 SAME = SAME.AND.ISAME( I )
1590 IF( .NOT.ISAME( I ) )
1591 $ WRITE( NOUT, FMT = 9998 )I+1
1592 30 CONTINUE
1593 IF( .NOT.SAME )THEN
1594 FATAL = .TRUE.
1595 GO TO 120
1596 END IF
1597 *
1598 IF( .NOT.NULL )THEN
1599 *
1600 * Check the result column by column.
1601 *
1602 JC = 1
1603 DO 40 J = 1, N
1604 IF( UPPER )THEN
1605 JJ = 1
1606 LJ = J
1607 ELSE
1608 JJ = J
1609 LJ = N - J + 1
1610 END IF
1611 IF( TRAN )THEN
1612 CALL SMMCH( 'T', 'N', LJ, 1, K, ALPHA,
1613 $ A( 1, JJ ), NMAX,
1614 $ A( 1, J ), NMAX, BETA,
1615 $ C( JJ, J ), NMAX, CT, G,
1616 $ CC( JC ), LDC, EPS, ERR,
1617 $ FATAL, NOUT, .TRUE. )
1618 ELSE
1619 CALL SMMCH( 'N', 'T', LJ, 1, K, ALPHA,
1620 $ A( JJ, 1 ), NMAX,
1621 $ A( J, 1 ), NMAX, BETA,
1622 $ C( JJ, J ), NMAX, CT, G,
1623 $ CC( JC ), LDC, EPS, ERR,
1624 $ FATAL, NOUT, .TRUE. )
1625 END IF
1626 IF( UPPER )THEN
1627 JC = JC + LDC
1628 ELSE
1629 JC = JC + LDC + 1
1630 END IF
1631 ERRMAX = MAX( ERRMAX, ERR )
1632 * If got really bad answer, report and
1633 * return.
1634 IF( FATAL )
1635 $ GO TO 110
1636 40 CONTINUE
1637 END IF
1638 *
1639 50 CONTINUE
1640 *
1641 60 CONTINUE
1642 *
1643 70 CONTINUE
1644 *
1645 80 CONTINUE
1646 *
1647 90 CONTINUE
1648 *
1649 100 CONTINUE
1650 *
1651 * Report result.
1652 *
1653 IF( ERRMAX.LT.THRESH )THEN
1654 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1655 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1656 ELSE
1657 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1658 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1659 END IF
1660 GO TO 130
1661 *
1662 110 CONTINUE
1663 IF( N.GT.1 )
1664 $ WRITE( NOUT, FMT = 9995 )J
1665 *
1666 120 CONTINUE
1667 WRITE( NOUT, FMT = 9996 )SNAME
1668 CALL SPRCN4( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA,
1669 $ LDA, BETA, LDC)
1670 *
1671 130 CONTINUE
1672 RETURN
1673 *
1674 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1675 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1676 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1677 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1678 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1679 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1680 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1681 $ ' (', I6, ' CALL', 'S)' )
1682 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1683 $ ' (', I6, ' CALL', 'S)' )
1684 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1685 $ 'ANGED INCORRECTLY *******' )
1686 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
1687 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1688 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1689 $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' )
1690 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1691 $ '******' )
1692 *
1693 * End of SCHK4.
1694 *
1695 END
1696 *
1697 SUBROUTINE SPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
1698 $ N, K, ALPHA, LDA, BETA, LDC)
1699 INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
1700 REAL ALPHA, BETA
1701 CHARACTER*1 UPLO, TRANSA
1702 CHARACTER*12 SNAME
1703 CHARACTER*14 CRC, CU, CA
1704
1705 IF (UPLO.EQ.'U')THEN
1706 CU = ' CblasUpper'
1707 ELSE
1708 CU = ' CblasLower'
1709 END IF
1710 IF (TRANSA.EQ.'N')THEN
1711 CA = ' CblasNoTrans'
1712 ELSE IF (TRANSA.EQ.'T')THEN
1713 CA = ' CblasTrans'
1714 ELSE
1715 CA = 'CblasConjTrans'
1716 END IF
1717 IF (IORDER.EQ.1)THEN
1718 CRC = ' CblasRowMajor'
1719 ELSE
1720 CRC = ' CblasColMajor'
1721 END IF
1722 WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
1723 WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC
1724
1725 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
1726 9994 FORMAT( 20X, 2( I3, ',' ),
1727 $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' )
1728 END
1729 *
1730 SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1731 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1732 $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
1733 $ IORDER )
1734 *
1735 * Tests SSYR2K.
1736 *
1737 * Auxiliary routine for test program for Level 3 Blas.
1738 *
1739 * -- Written on 8-February-1989.
1740 * Jack Dongarra, Argonne National Laboratory.
1741 * Iain Duff, AERE Harwell.
1742 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1743 * Sven Hammarling, Numerical Algorithms Group Ltd.
1744 *
1745 * .. Parameters ..
1746 REAL ZERO
1747 PARAMETER ( ZERO = 0.0 )
1748 * .. Scalar Arguments ..
1749 REAL EPS, THRESH
1750 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1751 LOGICAL FATAL, REWI, TRACE
1752 CHARACTER*12 SNAME
1753 * .. Array Arguments ..
1754 REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1755 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1756 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1757 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1758 $ G( NMAX ), W( 2*NMAX )
1759 INTEGER IDIM( NIDIM )
1760 * .. Local Scalars ..
1761 REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1762 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1763 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1764 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1765 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1766 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1767 CHARACTER*2 ICHU
1768 CHARACTER*3 ICHT
1769 * .. Local Arrays ..
1770 LOGICAL ISAME( 13 )
1771 * .. External Functions ..
1772 LOGICAL LSE, LSERES
1773 EXTERNAL LSE, LSERES
1774 * .. External Subroutines ..
1775 EXTERNAL SMAKE, SMMCH, CSSYR2K
1776 * .. Intrinsic Functions ..
1777 INTRINSIC MAX
1778 * .. Scalars in Common ..
1779 INTEGER INFOT, NOUTC
1780 LOGICAL OK
1781 * .. Common blocks ..
1782 COMMON /INFOC/INFOT, NOUTC, OK
1783 * .. Data statements ..
1784 DATA ICHT/'NTC'/, ICHU/'UL'/
1785 * .. Executable Statements ..
1786 *
1787 NARGS = 12
1788 NC = 0
1789 RESET = .TRUE.
1790 ERRMAX = ZERO
1791 *
1792 DO 130 IN = 1, NIDIM
1793 N = IDIM( IN )
1794 * Set LDC to 1 more than minimum value if room.
1795 LDC = N
1796 IF( LDC.LT.NMAX )
1797 $ LDC = LDC + 1
1798 * Skip tests if not enough room.
1799 IF( LDC.GT.NMAX )
1800 $ GO TO 130
1801 LCC = LDC*N
1802 NULL = N.LE.0
1803 *
1804 DO 120 IK = 1, NIDIM
1805 K = IDIM( IK )
1806 *
1807 DO 110 ICT = 1, 3
1808 TRANS = ICHT( ICT: ICT )
1809 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
1810 IF( TRAN )THEN
1811 MA = K
1812 NA = N
1813 ELSE
1814 MA = N
1815 NA = K
1816 END IF
1817 * Set LDA to 1 more than minimum value if room.
1818 LDA = MA
1819 IF( LDA.LT.NMAX )
1820 $ LDA = LDA + 1
1821 * Skip tests if not enough room.
1822 IF( LDA.GT.NMAX )
1823 $ GO TO 110
1824 LAA = LDA*NA
1825 *
1826 * Generate the matrix A.
1827 *
1828 IF( TRAN )THEN
1829 CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA,
1830 $ LDA, RESET, ZERO )
1831 ELSE
1832 CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA,
1833 $ RESET, ZERO )
1834 END IF
1835 *
1836 * Generate the matrix B.
1837 *
1838 LDB = LDA
1839 LBB = LAA
1840 IF( TRAN )THEN
1841 CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ),
1842 $ 2*NMAX, BB, LDB, RESET, ZERO )
1843 ELSE
1844 CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ),
1845 $ NMAX, BB, LDB, RESET, ZERO )
1846 END IF
1847 *
1848 DO 100 ICU = 1, 2
1849 UPLO = ICHU( ICU: ICU )
1850 UPPER = UPLO.EQ.'U'
1851 *
1852 DO 90 IA = 1, NALF
1853 ALPHA = ALF( IA )
1854 *
1855 DO 80 IB = 1, NBET
1856 BETA = BET( IB )
1857 *
1858 * Generate the matrix C.
1859 *
1860 CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
1861 $ LDC, RESET, ZERO )
1862 *
1863 NC = NC + 1
1864 *
1865 * Save every datum before calling the subroutine.
1866 *
1867 UPLOS = UPLO
1868 TRANSS = TRANS
1869 NS = N
1870 KS = K
1871 ALS = ALPHA
1872 DO 10 I = 1, LAA
1873 AS( I ) = AA( I )
1874 10 CONTINUE
1875 LDAS = LDA
1876 DO 20 I = 1, LBB
1877 BS( I ) = BB( I )
1878 20 CONTINUE
1879 LDBS = LDB
1880 BETS = BETA
1881 DO 30 I = 1, LCC
1882 CS( I ) = CC( I )
1883 30 CONTINUE
1884 LDCS = LDC
1885 *
1886 * Call the subroutine.
1887 *
1888 IF( TRACE )
1889 $ CALL SPRCN5( NTRA, NC, SNAME, IORDER, UPLO,
1890 $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC)
1891 IF( REWI )
1892 $ REWIND NTRA
1893 CALL CSSYR2K( IORDER, UPLO, TRANS, N, K, ALPHA,
1894 $ AA, LDA, BB, LDB, BETA, CC, LDC )
1895 *
1896 * Check if error-exit was taken incorrectly.
1897 *
1898 IF( .NOT.OK )THEN
1899 WRITE( NOUT, FMT = 9993 )
1900 FATAL = .TRUE.
1901 GO TO 150
1902 END IF
1903 *
1904 * See what data changed inside subroutines.
1905 *
1906 ISAME( 1 ) = UPLOS.EQ.UPLO
1907 ISAME( 2 ) = TRANSS.EQ.TRANS
1908 ISAME( 3 ) = NS.EQ.N
1909 ISAME( 4 ) = KS.EQ.K
1910 ISAME( 5 ) = ALS.EQ.ALPHA
1911 ISAME( 6 ) = LSE( AS, AA, LAA )
1912 ISAME( 7 ) = LDAS.EQ.LDA
1913 ISAME( 8 ) = LSE( BS, BB, LBB )
1914 ISAME( 9 ) = LDBS.EQ.LDB
1915 ISAME( 10 ) = BETS.EQ.BETA
1916 IF( NULL )THEN
1917 ISAME( 11 ) = LSE( CS, CC, LCC )
1918 ELSE
1919 ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, CS,
1920 $ CC, LDC )
1921 END IF
1922 ISAME( 12 ) = LDCS.EQ.LDC
1923 *
1924 * If data was incorrectly changed, report and
1925 * return.
1926 *
1927 SAME = .TRUE.
1928 DO 40 I = 1, NARGS
1929 SAME = SAME.AND.ISAME( I )
1930 IF( .NOT.ISAME( I ) )
1931 $ WRITE( NOUT, FMT = 9998 )I+1
1932 40 CONTINUE
1933 IF( .NOT.SAME )THEN
1934 FATAL = .TRUE.
1935 GO TO 150
1936 END IF
1937 *
1938 IF( .NOT.NULL )THEN
1939 *
1940 * Check the result column by column.
1941 *
1942 JJAB = 1
1943 JC = 1
1944 DO 70 J = 1, N
1945 IF( UPPER )THEN
1946 JJ = 1
1947 LJ = J
1948 ELSE
1949 JJ = J
1950 LJ = N - J + 1
1951 END IF
1952 IF( TRAN )THEN
1953 DO 50 I = 1, K
1954 W( I ) = AB( ( J - 1 )*2*NMAX + K +
1955 $ I )
1956 W( K + I ) = AB( ( J - 1 )*2*NMAX +
1957 $ I )
1958 50 CONTINUE
1959 CALL SMMCH( 'T', 'N', LJ, 1, 2*K,
1960 $ ALPHA, AB( JJAB ), 2*NMAX,
1961 $ W, 2*NMAX, BETA,
1962 $ C( JJ, J ), NMAX, CT, G,
1963 $ CC( JC ), LDC, EPS, ERR,
1964 $ FATAL, NOUT, .TRUE. )
1965 ELSE
1966 DO 60 I = 1, K
1967 W( I ) = AB( ( K + I - 1 )*NMAX +
1968 $ J )
1969 W( K + I ) = AB( ( I - 1 )*NMAX +
1970 $ J )
1971 60 CONTINUE
1972 CALL SMMCH( 'N', 'N', LJ, 1, 2*K,
1973 $ ALPHA, AB( JJ ), NMAX, W,
1974 $ 2*NMAX, BETA, C( JJ, J ),
1975 $ NMAX, CT, G, CC( JC ), LDC,
1976 $ EPS, ERR, FATAL, NOUT,
1977 $ .TRUE. )
1978 END IF
1979 IF( UPPER )THEN
1980 JC = JC + LDC
1981 ELSE
1982 JC = JC + LDC + 1
1983 IF( TRAN )
1984 $ JJAB = JJAB + 2*NMAX
1985 END IF
1986 ERRMAX = MAX( ERRMAX, ERR )
1987 * If got really bad answer, report and
1988 * return.
1989 IF( FATAL )
1990 $ GO TO 140
1991 70 CONTINUE
1992 END IF
1993 *
1994 80 CONTINUE
1995 *
1996 90 CONTINUE
1997 *
1998 100 CONTINUE
1999 *
2000 110 CONTINUE
2001 *
2002 120 CONTINUE
2003 *
2004 130 CONTINUE
2005 *
2006 * Report result.
2007 *
2008 IF( ERRMAX.LT.THRESH )THEN
2009 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
2010 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
2011 ELSE
2012 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
2013 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
2014 END IF
2015 GO TO 160
2016 *
2017 140 CONTINUE
2018 IF( N.GT.1 )
2019 $ WRITE( NOUT, FMT = 9995 )J
2020 *
2021 150 CONTINUE
2022 WRITE( NOUT, FMT = 9996 )SNAME
2023 CALL SPRCN5( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA,
2024 $ LDA, LDB, BETA, LDC)
2025 *
2026 160 CONTINUE
2027 RETURN
2028 *
2029 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2030 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2031 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
2032 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2033 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2034 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
2035 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2036 $ ' (', I6, ' CALL', 'S)' )
2037 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2038 $ ' (', I6, ' CALL', 'S)' )
2039 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
2040 $ 'ANGED INCORRECTLY *******' )
2041 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
2042 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
2043 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
2044 $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
2045 $ ' .' )
2046 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2047 $ '******' )
2048 *
2049 * End of SCHK5.
2050 *
2051 END
2052 *
2053 SUBROUTINE SPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
2054 $ N, K, ALPHA, LDA, LDB, BETA, LDC)
2055 INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
2056 REAL ALPHA, BETA
2057 CHARACTER*1 UPLO, TRANSA
2058 CHARACTER*12 SNAME
2059 CHARACTER*14 CRC, CU, CA
2060
2061 IF (UPLO.EQ.'U')THEN
2062 CU = ' CblasUpper'
2063 ELSE
2064 CU = ' CblasLower'
2065 END IF
2066 IF (TRANSA.EQ.'N')THEN
2067 CA = ' CblasNoTrans'
2068 ELSE IF (TRANSA.EQ.'T')THEN
2069 CA = ' CblasTrans'
2070 ELSE
2071 CA = 'CblasConjTrans'
2072 END IF
2073 IF (IORDER.EQ.1)THEN
2074 CRC = ' CblasRowMajor'
2075 ELSE
2076 CRC = ' CblasColMajor'
2077 END IF
2078 WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
2079 WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
2080
2081 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
2082 9994 FORMAT( 20X, 2( I3, ',' ),
2083 $ F4.1, ', A,', I3, ', B', I3, ',', F4.1, ', C,', I3, ').' )
2084 END
2085 *
2086 SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
2087 $ TRANSL )
2088 *
2089 * Generates values for an M by N matrix A.
2090 * Stores the values in the array AA in the data structure required
2091 * by the routine, with unwanted elements set to rogue value.
2092 *
2093 * TYPE is 'GE', 'SY' or 'TR'.
2094 *
2095 * Auxiliary routine for test program for Level 3 Blas.
2096 *
2097 * -- Written on 8-February-1989.
2098 * Jack Dongarra, Argonne National Laboratory.
2099 * Iain Duff, AERE Harwell.
2100 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2101 * Sven Hammarling, Numerical Algorithms Group Ltd.
2102 *
2103 * .. Parameters ..
2104 REAL ZERO, ONE
2105 PARAMETER ( ZERO = 0.0, ONE = 1.0 )
2106 REAL ROGUE
2107 PARAMETER ( ROGUE = -1.0E10 )
2108 * .. Scalar Arguments ..
2109 REAL TRANSL
2110 INTEGER LDA, M, N, NMAX
2111 LOGICAL RESET
2112 CHARACTER*1 DIAG, UPLO
2113 CHARACTER*2 TYPE
2114 * .. Array Arguments ..
2115 REAL A( NMAX, * ), AA( * )
2116 * .. Local Scalars ..
2117 INTEGER I, IBEG, IEND, J
2118 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2119 * .. External Functions ..
2120 REAL SBEG
2121 EXTERNAL SBEG
2122 * .. Executable Statements ..
2123 GEN = TYPE.EQ.'GE'
2124 SYM = TYPE.EQ.'SY'
2125 TRI = TYPE.EQ.'TR'
2126 UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
2127 LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
2128 UNIT = TRI.AND.DIAG.EQ.'U'
2129 *
2130 * Generate data in array A.
2131 *
2132 DO 20 J = 1, N
2133 DO 10 I = 1, M
2134 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
2135 $ THEN
2136 A( I, J ) = SBEG( RESET ) + TRANSL
2137 IF( I.NE.J )THEN
2138 * Set some elements to zero
2139 IF( N.GT.3.AND.J.EQ.N/2 )
2140 $ A( I, J ) = ZERO
2141 IF( SYM )THEN
2142 A( J, I ) = A( I, J )
2143 ELSE IF( TRI )THEN
2144 A( J, I ) = ZERO
2145 END IF
2146 END IF
2147 END IF
2148 10 CONTINUE
2149 IF( TRI )
2150 $ A( J, J ) = A( J, J ) + ONE
2151 IF( UNIT )
2152 $ A( J, J ) = ONE
2153 20 CONTINUE
2154 *
2155 * Store elements in array AS in data structure required by routine.
2156 *
2157 IF( TYPE.EQ.'GE' )THEN
2158 DO 50 J = 1, N
2159 DO 30 I = 1, M
2160 AA( I + ( J - 1 )*LDA ) = A( I, J )
2161 30 CONTINUE
2162 DO 40 I = M + 1, LDA
2163 AA( I + ( J - 1 )*LDA ) = ROGUE
2164 40 CONTINUE
2165 50 CONTINUE
2166 ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
2167 DO 90 J = 1, N
2168 IF( UPPER )THEN
2169 IBEG = 1
2170 IF( UNIT )THEN
2171 IEND = J - 1
2172 ELSE
2173 IEND = J
2174 END IF
2175 ELSE
2176 IF( UNIT )THEN
2177 IBEG = J + 1
2178 ELSE
2179 IBEG = J
2180 END IF
2181 IEND = N
2182 END IF
2183 DO 60 I = 1, IBEG - 1
2184 AA( I + ( J - 1 )*LDA ) = ROGUE
2185 60 CONTINUE
2186 DO 70 I = IBEG, IEND
2187 AA( I + ( J - 1 )*LDA ) = A( I, J )
2188 70 CONTINUE
2189 DO 80 I = IEND + 1, LDA
2190 AA( I + ( J - 1 )*LDA ) = ROGUE
2191 80 CONTINUE
2192 90 CONTINUE
2193 END IF
2194 RETURN
2195 *
2196 * End of SMAKE.
2197 *
2198 END
2199 SUBROUTINE SMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
2200 $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
2201 $ NOUT, MV )
2202 *
2203 * Checks the results of the computational tests.
2204 *
2205 * Auxiliary routine for test program for Level 3 Blas.
2206 *
2207 * -- Written on 8-February-1989.
2208 * Jack Dongarra, Argonne National Laboratory.
2209 * Iain Duff, AERE Harwell.
2210 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2211 * Sven Hammarling, Numerical Algorithms Group Ltd.
2212 *
2213 * .. Parameters ..
2214 REAL ZERO, ONE
2215 PARAMETER ( ZERO = 0.0, ONE = 1.0 )
2216 * .. Scalar Arguments ..
2217 REAL ALPHA, BETA, EPS, ERR
2218 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
2219 LOGICAL FATAL, MV
2220 CHARACTER*1 TRANSA, TRANSB
2221 * .. Array Arguments ..
2222 REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
2223 $ CC( LDCC, * ), CT( * ), G( * )
2224 * .. Local Scalars ..
2225 REAL ERRI
2226 INTEGER I, J, K
2227 LOGICAL TRANA, TRANB
2228 * .. Intrinsic Functions ..
2229 INTRINSIC ABS, MAX, SQRT
2230 * .. Executable Statements ..
2231 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
2232 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
2233 *
2234 * Compute expected result, one column at a time, in CT using data
2235 * in A, B and C.
2236 * Compute gauges in G.
2237 *
2238 DO 120 J = 1, N
2239 *
2240 DO 10 I = 1, M
2241 CT( I ) = ZERO
2242 G( I ) = ZERO
2243 10 CONTINUE
2244 IF( .NOT.TRANA.AND..NOT.TRANB )THEN
2245 DO 30 K = 1, KK
2246 DO 20 I = 1, M
2247 CT( I ) = CT( I ) + A( I, K )*B( K, J )
2248 G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) )
2249 20 CONTINUE
2250 30 CONTINUE
2251 ELSE IF( TRANA.AND..NOT.TRANB )THEN
2252 DO 50 K = 1, KK
2253 DO 40 I = 1, M
2254 CT( I ) = CT( I ) + A( K, I )*B( K, J )
2255 G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) )
2256 40 CONTINUE
2257 50 CONTINUE
2258 ELSE IF( .NOT.TRANA.AND.TRANB )THEN
2259 DO 70 K = 1, KK
2260 DO 60 I = 1, M
2261 CT( I ) = CT( I ) + A( I, K )*B( J, K )
2262 G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) )
2263 60 CONTINUE
2264 70 CONTINUE
2265 ELSE IF( TRANA.AND.TRANB )THEN
2266 DO 90 K = 1, KK
2267 DO 80 I = 1, M
2268 CT( I ) = CT( I ) + A( K, I )*B( J, K )
2269 G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) )
2270 80 CONTINUE
2271 90 CONTINUE
2272 END IF
2273 DO 100 I = 1, M
2274 CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
2275 G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) )
2276 100 CONTINUE
2277 *
2278 * Compute the error ratio for this result.
2279 *
2280 ERR = ZERO
2281 DO 110 I = 1, M
2282 ERRI = ABS( CT( I ) - CC( I, J ) )/EPS
2283 IF( G( I ).NE.ZERO )
2284 $ ERRI = ERRI/G( I )
2285 ERR = MAX( ERR, ERRI )
2286 IF( ERR*SQRT( EPS ).GE.ONE )
2287 $ GO TO 130
2288 110 CONTINUE
2289 *
2290 120 CONTINUE
2291 *
2292 * If the loop completes, all results are at least half accurate.
2293 GO TO 150
2294 *
2295 * Report fatal error.
2296 *
2297 130 FATAL = .TRUE.
2298 WRITE( NOUT, FMT = 9999 )
2299 DO 140 I = 1, M
2300 IF( MV )THEN
2301 WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
2302 ELSE
2303 WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
2304 END IF
2305 140 CONTINUE
2306 IF( N.GT.1 )
2307 $ WRITE( NOUT, FMT = 9997 )J
2308 *
2309 150 CONTINUE
2310 RETURN
2311 *
2312 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2313 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2314 $ 'TED RESULT' )
2315 9998 FORMAT( 1X, I7, 2G18.6 )
2316 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
2317 *
2318 * End of SMMCH.
2319 *
2320 END
2321 LOGICAL FUNCTION LSE( RI, RJ, LR )
2322 *
2323 * Tests if two arrays are identical.
2324 *
2325 * Auxiliary routine for test program for Level 3 Blas.
2326 *
2327 * -- Written on 8-February-1989.
2328 * Jack Dongarra, Argonne National Laboratory.
2329 * Iain Duff, AERE Harwell.
2330 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2331 * Sven Hammarling, Numerical Algorithms Group Ltd.
2332 *
2333 * .. Scalar Arguments ..
2334 INTEGER LR
2335 * .. Array Arguments ..
2336 REAL RI( * ), RJ( * )
2337 * .. Local Scalars ..
2338 INTEGER I
2339 * .. Executable Statements ..
2340 DO 10 I = 1, LR
2341 IF( RI( I ).NE.RJ( I ) )
2342 $ GO TO 20
2343 10 CONTINUE
2344 LSE = .TRUE.
2345 GO TO 30
2346 20 CONTINUE
2347 LSE = .FALSE.
2348 30 RETURN
2349 *
2350 * End of LSE.
2351 *
2352 END
2353 LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA )
2354 *
2355 * Tests if selected elements in two arrays are equal.
2356 *
2357 * TYPE is 'GE' or 'SY'.
2358 *
2359 * Auxiliary routine for test program for Level 3 Blas.
2360 *
2361 * -- Written on 8-February-1989.
2362 * Jack Dongarra, Argonne National Laboratory.
2363 * Iain Duff, AERE Harwell.
2364 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2365 * Sven Hammarling, Numerical Algorithms Group Ltd.
2366 *
2367 * .. Scalar Arguments ..
2368 INTEGER LDA, M, N
2369 CHARACTER*1 UPLO
2370 CHARACTER*2 TYPE
2371 * .. Array Arguments ..
2372 REAL AA( LDA, * ), AS( LDA, * )
2373 * .. Local Scalars ..
2374 INTEGER I, IBEG, IEND, J
2375 LOGICAL UPPER
2376 * .. Executable Statements ..
2377 UPPER = UPLO.EQ.'U'
2378 IF( TYPE.EQ.'GE' )THEN
2379 DO 20 J = 1, N
2380 DO 10 I = M + 1, LDA
2381 IF( AA( I, J ).NE.AS( I, J ) )
2382 $ GO TO 70
2383 10 CONTINUE
2384 20 CONTINUE
2385 ELSE IF( TYPE.EQ.'SY' )THEN
2386 DO 50 J = 1, N
2387 IF( UPPER )THEN
2388 IBEG = 1
2389 IEND = J
2390 ELSE
2391 IBEG = J
2392 IEND = N
2393 END IF
2394 DO 30 I = 1, IBEG - 1
2395 IF( AA( I, J ).NE.AS( I, J ) )
2396 $ GO TO 70
2397 30 CONTINUE
2398 DO 40 I = IEND + 1, LDA
2399 IF( AA( I, J ).NE.AS( I, J ) )
2400 $ GO TO 70
2401 40 CONTINUE
2402 50 CONTINUE
2403 END IF
2404 *
2405 60 CONTINUE
2406 LSERES = .TRUE.
2407 GO TO 80
2408 70 CONTINUE
2409 LSERES = .FALSE.
2410 80 RETURN
2411 *
2412 * End of LSERES.
2413 *
2414 END
2415 REAL FUNCTION SBEG( RESET )
2416 *
2417 * Generates random numbers uniformly distributed between -0.5 and 0.5.
2418 *
2419 * Auxiliary routine for test program for Level 3 Blas.
2420 *
2421 * -- Written on 8-February-1989.
2422 * Jack Dongarra, Argonne National Laboratory.
2423 * Iain Duff, AERE Harwell.
2424 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2425 * Sven Hammarling, Numerical Algorithms Group Ltd.
2426 *
2427 * .. Scalar Arguments ..
2428 LOGICAL RESET
2429 * .. Local Scalars ..
2430 INTEGER I, IC, MI
2431 * .. Save statement ..
2432 SAVE I, IC, MI
2433 * .. Executable Statements ..
2434 IF( RESET )THEN
2435 * Initialize local variables.
2436 MI = 891
2437 I = 7
2438 IC = 0
2439 RESET = .FALSE.
2440 END IF
2441 *
2442 * The sequence of values of I is bounded between 1 and 999.
2443 * If initial I = 1,2,3,6,7 or 9, the period will be 50.
2444 * If initial I = 4 or 8, the period will be 25.
2445 * If initial I = 5, the period will be 10.
2446 * IC is used to break up the period by skipping 1 value of I in 6.
2447 *
2448 IC = IC + 1
2449 10 I = I*MI
2450 I = I - 1000*( I/1000 )
2451 IF( IC.GE.5 )THEN
2452 IC = 0
2453 GO TO 10
2454 END IF
2455 SBEG = ( I - 500 )/1001.0
2456 RETURN
2457 *
2458 * End of SBEG.
2459 *
2460 END
2461 REAL FUNCTION SDIFF( X, Y )
2462 *
2463 * Auxiliary routine for test program for Level 3 Blas.
2464 *
2465 * -- Written on 8-February-1989.
2466 * Jack Dongarra, Argonne National Laboratory.
2467 * Iain Duff, AERE Harwell.
2468 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2469 * Sven Hammarling, Numerical Algorithms Group Ltd.
2470 *
2471 * .. Scalar Arguments ..
2472 REAL X, Y
2473 * .. Executable Statements ..
2474 SDIFF = X - Y
2475 RETURN
2476 *
2477 * End of SDIFF.
2478 *
2479 END
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 *
383 10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
384 10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' )
385 10000 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 *
684 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
685 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
686 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
687 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
688 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
689 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
690 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
691 $ ' (', I6, ' CALL', 'S)' )
692 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
693 $ ' (', I6, ' CALL', 'S)' )
694 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
695 $ 'ANGED INCORRECTLY *******' )
696 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
697 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',',
698 $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
699 $ 'C,', I3, ').' )
700 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
701 $ '******' )
702 *
703 * End of 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 *
1001 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1002 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1003 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1004 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1005 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1006 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1007 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1008 $ ' (', I6, ' CALL', 'S)' )
1009 10000 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 IF( LDB.LT.NMAX )
1130 $ LDB = LDB + 1
1131 * Skip tests if not enough room.
1132 IF( LDB.GT.NMAX )
1133 $ GO TO 130
1134 LBB = LDB*N
1135 NULL = M.LE.0.OR.N.LE.0
1136 *
1137 DO 120 ICS = 1, 2
1138 SIDE = ICHS( ICS: ICS )
1139 LEFT = SIDE.EQ.'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 IF( LDA.LT.NMAX )
1148 $ LDA = LDA + 1
1149 * Skip tests if not enough room.
1150 IF( LDA.GT.NMAX )
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 IF( SNAME( 10: 11 ).EQ.'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 ELSE IF( SNAME( 10: 11 ).EQ.'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 IF( .NOT.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 ISAME( 1 ) = SIDES.EQ.SIDE
1232 ISAME( 2 ) = UPLOS.EQ.UPLO
1233 ISAME( 3 ) = TRANAS.EQ.TRANSA
1234 ISAME( 4 ) = DIAGS.EQ.DIAG
1235 ISAME( 5 ) = MS.EQ.M
1236 ISAME( 6 ) = NS.EQ.N
1237 ISAME( 7 ) = ALS.EQ.ALPHA
1238 ISAME( 8 ) = LSE( AS, AA, LAA )
1239 ISAME( 9 ) = LDAS.EQ.LDA
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 ISAME( 11 ) = LDBS.EQ.LDB
1247 *
1248 * If data was incorrectly changed, report and
1249 * return.
1250 *
1251 SAME = .TRUE.
1252 DO 50 I = 1, NARGS
1253 SAME = SAME.AND.ISAME( I )
1254 IF( .NOT.ISAME( I ) )
1255 $ WRITE( NOUT, FMT = 9998 )I+1
1256 50 CONTINUE
1257 IF( .NOT.SAME )THEN
1258 FATAL = .TRUE.
1259 GO TO 150
1260 END IF
1261 *
1262 IF( .NOT.NULL )THEN
1263 IF( SNAME( 10: 11 ).EQ.'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 ELSE IF( SNAME( 10: 11 ).EQ.'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 IF( ERRMAX.LT.THRESH )THEN
1332 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1333 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1334 ELSE
1335 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1336 IF ( IORDER.EQ.1) 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 CALL SPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG,
1343 $ M, N, ALPHA, LDA, LDB)
1344 *
1345 160 CONTINUE
1346 RETURN
1347 *
1348 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1349 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1350 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1351 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1352 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1353 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1354 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1355 $ ' (', I6, ' CALL', 'S)' )
1356 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1357 $ ' (', I6, ' CALL', 'S)' )
1358 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1359 $ 'ANGED INCORRECTLY *******' )
1360 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
1361 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ),
1362 $ F4.1, ', A,', I3, ', B,', I3, ') .' )
1363 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1364 $ '******' )
1365 *
1366 * End of SCHK3.
1367 *
1368 END
1369 *
1370 SUBROUTINE SPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA,
1371 $ DIAG, M, N, ALPHA, LDA, LDB)
1372 INTEGER NOUT, NC, IORDER, M, N, LDA, LDB
1373 REAL ALPHA
1374 CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
1375 CHARACTER*12 SNAME
1376 CHARACTER*14 CRC, CS, CU, CA, CD
1377
1378 IF (SIDE.EQ.'L')THEN
1379 CS = ' CblasLeft'
1380 ELSE
1381 CS = ' CblasRight'
1382 END IF
1383 IF (UPLO.EQ.'U')THEN
1384 CU = ' CblasUpper'
1385 ELSE
1386 CU = ' CblasLower'
1387 END IF
1388 IF (TRANSA.EQ.'N')THEN
1389 CA = ' CblasNoTrans'
1390 ELSE IF (TRANSA.EQ.'T')THEN
1391 CA = ' CblasTrans'
1392 ELSE
1393 CA = 'CblasConjTrans'
1394 END IF
1395 IF (DIAG.EQ.'N')THEN
1396 CD = ' CblasNonUnit'
1397 ELSE
1398 CD = ' CblasUnit'
1399 END IF
1400 IF (IORDER.EQ.1)THEN
1401 CRC = 'CblasRowMajor'
1402 ELSE
1403 CRC = 'CblasColMajor'
1404 END IF
1405 WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
1406 WRITE(NOUT, FMT = 9994)CA, CD, M, N, ALPHA, LDA, LDB
1407
1408 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
1409 9994 FORMAT( 22X, 2( A14, ',') , 2( I3, ',' ),
1410 $ F4.1, ', A,', I3, ', B,', I3, ').' )
1411 END
1412 *
1413 SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1414 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1415 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G,
1416 $ IORDER )
1417 *
1418 * Tests SSYRK.
1419 *
1420 * Auxiliary routine for test program for Level 3 Blas.
1421 *
1422 * -- Written on 8-February-1989.
1423 * Jack Dongarra, Argonne National Laboratory.
1424 * Iain Duff, AERE Harwell.
1425 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1426 * Sven Hammarling, Numerical Algorithms Group Ltd.
1427 *
1428 * .. Parameters ..
1429 REAL ZERO
1430 PARAMETER ( ZERO = 0.0 )
1431 * .. Scalar Arguments ..
1432 REAL EPS, THRESH
1433 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1434 LOGICAL FATAL, REWI, TRACE
1435 CHARACTER*12 SNAME
1436 * .. Array Arguments ..
1437 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1438 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1439 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
1440 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
1441 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
1442 INTEGER IDIM( NIDIM )
1443 * .. Local Scalars ..
1444 REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1445 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1446 $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1447 $ NARGS, NC, NS
1448 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1449 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1450 CHARACTER*2 ICHU
1451 CHARACTER*3 ICHT
1452 * .. Local Arrays ..
1453 LOGICAL ISAME( 13 )
1454 * .. External Functions ..
1455 LOGICAL LSE, LSERES
1456 EXTERNAL LSE, LSERES
1457 * .. External Subroutines ..
1458 EXTERNAL SMAKE, SMMCH, CSSYRK
1459 * .. Intrinsic Functions ..
1460 INTRINSIC MAX
1461 * .. Scalars in Common ..
1462 INTEGER INFOT, NOUTC
1463 LOGICAL OK
1464 * .. Common blocks ..
1465 COMMON /INFOC/INFOT, NOUTC, OK
1466 * .. Data statements ..
1467 DATA ICHT/'NTC'/, ICHU/'UL'/
1468 * .. Executable Statements ..
1469 *
1470 NARGS = 10
1471 NC = 0
1472 RESET = .TRUE.
1473 ERRMAX = ZERO
1474 *
1475 DO 100 IN = 1, NIDIM
1476 N = IDIM( IN )
1477 * Set LDC to 1 more than minimum value if room.
1478 LDC = N
1479 IF( LDC.LT.NMAX )
1480 $ LDC = LDC + 1
1481 * Skip tests if not enough room.
1482 IF( LDC.GT.NMAX )
1483 $ GO TO 100
1484 LCC = LDC*N
1485 NULL = N.LE.0
1486 *
1487 DO 90 IK = 1, NIDIM
1488 K = IDIM( IK )
1489 *
1490 DO 80 ICT = 1, 3
1491 TRANS = ICHT( ICT: ICT )
1492 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
1493 IF( TRAN )THEN
1494 MA = K
1495 NA = N
1496 ELSE
1497 MA = N
1498 NA = K
1499 END IF
1500 * Set LDA to 1 more than minimum value if room.
1501 LDA = MA
1502 IF( LDA.LT.NMAX )
1503 $ LDA = LDA + 1
1504 * Skip tests if not enough room.
1505 IF( LDA.GT.NMAX )
1506 $ GO TO 80
1507 LAA = LDA*NA
1508 *
1509 * Generate the matrix A.
1510 *
1511 CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
1512 $ RESET, ZERO )
1513 *
1514 DO 70 ICU = 1, 2
1515 UPLO = ICHU( ICU: ICU )
1516 UPPER = UPLO.EQ.'U'
1517 *
1518 DO 60 IA = 1, NALF
1519 ALPHA = ALF( IA )
1520 *
1521 DO 50 IB = 1, NBET
1522 BETA = BET( IB )
1523 *
1524 * Generate the matrix C.
1525 *
1526 CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
1527 $ LDC, RESET, ZERO )
1528 *
1529 NC = NC + 1
1530 *
1531 * Save every datum before calling the subroutine.
1532 *
1533 UPLOS = UPLO
1534 TRANSS = TRANS
1535 NS = N
1536 KS = K
1537 ALS = ALPHA
1538 DO 10 I = 1, LAA
1539 AS( I ) = AA( I )
1540 10 CONTINUE
1541 LDAS = LDA
1542 BETS = BETA
1543 DO 20 I = 1, LCC
1544 CS( I ) = CC( I )
1545 20 CONTINUE
1546 LDCS = LDC
1547 *
1548 * Call the subroutine.
1549 *
1550 IF( TRACE )
1551 $ CALL SPRCN4( NTRA, NC, SNAME, IORDER, UPLO,
1552 $ TRANS, N, K, ALPHA, LDA, BETA, LDC)
1553 IF( REWI )
1554 $ REWIND NTRA
1555 CALL CSSYRK( IORDER, UPLO, TRANS, N, K, ALPHA,
1556 $ AA, LDA, BETA, CC, LDC )
1557 *
1558 * Check if error-exit was taken incorrectly.
1559 *
1560 IF( .NOT.OK )THEN
1561 WRITE( NOUT, FMT = 9993 )
1562 FATAL = .TRUE.
1563 GO TO 120
1564 END IF
1565 *
1566 * See what data changed inside subroutines.
1567 *
1568 ISAME( 1 ) = UPLOS.EQ.UPLO
1569 ISAME( 2 ) = TRANSS.EQ.TRANS
1570 ISAME( 3 ) = NS.EQ.N
1571 ISAME( 4 ) = KS.EQ.K
1572 ISAME( 5 ) = ALS.EQ.ALPHA
1573 ISAME( 6 ) = LSE( AS, AA, LAA )
1574 ISAME( 7 ) = LDAS.EQ.LDA
1575 ISAME( 8 ) = BETS.EQ.BETA
1576 IF( NULL )THEN
1577 ISAME( 9 ) = LSE( CS, CC, LCC )
1578 ELSE
1579 ISAME( 9 ) = LSERES( 'SY', UPLO, N, N, CS,
1580 $ CC, LDC )
1581 END IF
1582 ISAME( 10 ) = LDCS.EQ.LDC
1583 *
1584 * If data was incorrectly changed, report and
1585 * return.
1586 *
1587 SAME = .TRUE.
1588 DO 30 I = 1, NARGS
1589 SAME = SAME.AND.ISAME( I )
1590 IF( .NOT.ISAME( I ) )
1591 $ WRITE( NOUT, FMT = 9998 )I+1
1592 30 CONTINUE
1593 IF( .NOT.SAME )THEN
1594 FATAL = .TRUE.
1595 GO TO 120
1596 END IF
1597 *
1598 IF( .NOT.NULL )THEN
1599 *
1600 * Check the result column by column.
1601 *
1602 JC = 1
1603 DO 40 J = 1, N
1604 IF( UPPER )THEN
1605 JJ = 1
1606 LJ = J
1607 ELSE
1608 JJ = J
1609 LJ = N - J + 1
1610 END IF
1611 IF( TRAN )THEN
1612 CALL SMMCH( 'T', 'N', LJ, 1, K, ALPHA,
1613 $ A( 1, JJ ), NMAX,
1614 $ A( 1, J ), NMAX, BETA,
1615 $ C( JJ, J ), NMAX, CT, G,
1616 $ CC( JC ), LDC, EPS, ERR,
1617 $ FATAL, NOUT, .TRUE. )
1618 ELSE
1619 CALL SMMCH( 'N', 'T', LJ, 1, K, ALPHA,
1620 $ A( JJ, 1 ), NMAX,
1621 $ A( J, 1 ), NMAX, BETA,
1622 $ C( JJ, J ), NMAX, CT, G,
1623 $ CC( JC ), LDC, EPS, ERR,
1624 $ FATAL, NOUT, .TRUE. )
1625 END IF
1626 IF( UPPER )THEN
1627 JC = JC + LDC
1628 ELSE
1629 JC = JC + LDC + 1
1630 END IF
1631 ERRMAX = MAX( ERRMAX, ERR )
1632 * If got really bad answer, report and
1633 * return.
1634 IF( FATAL )
1635 $ GO TO 110
1636 40 CONTINUE
1637 END IF
1638 *
1639 50 CONTINUE
1640 *
1641 60 CONTINUE
1642 *
1643 70 CONTINUE
1644 *
1645 80 CONTINUE
1646 *
1647 90 CONTINUE
1648 *
1649 100 CONTINUE
1650 *
1651 * Report result.
1652 *
1653 IF( ERRMAX.LT.THRESH )THEN
1654 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1655 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1656 ELSE
1657 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1658 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1659 END IF
1660 GO TO 130
1661 *
1662 110 CONTINUE
1663 IF( N.GT.1 )
1664 $ WRITE( NOUT, FMT = 9995 )J
1665 *
1666 120 CONTINUE
1667 WRITE( NOUT, FMT = 9996 )SNAME
1668 CALL SPRCN4( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA,
1669 $ LDA, BETA, LDC)
1670 *
1671 130 CONTINUE
1672 RETURN
1673 *
1674 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1675 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1676 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1677 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1678 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1679 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
1680 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1681 $ ' (', I6, ' CALL', 'S)' )
1682 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1683 $ ' (', I6, ' CALL', 'S)' )
1684 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1685 $ 'ANGED INCORRECTLY *******' )
1686 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
1687 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1688 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1689 $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' )
1690 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1691 $ '******' )
1692 *
1693 * End of SCHK4.
1694 *
1695 END
1696 *
1697 SUBROUTINE SPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
1698 $ N, K, ALPHA, LDA, BETA, LDC)
1699 INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
1700 REAL ALPHA, BETA
1701 CHARACTER*1 UPLO, TRANSA
1702 CHARACTER*12 SNAME
1703 CHARACTER*14 CRC, CU, CA
1704
1705 IF (UPLO.EQ.'U')THEN
1706 CU = ' CblasUpper'
1707 ELSE
1708 CU = ' CblasLower'
1709 END IF
1710 IF (TRANSA.EQ.'N')THEN
1711 CA = ' CblasNoTrans'
1712 ELSE IF (TRANSA.EQ.'T')THEN
1713 CA = ' CblasTrans'
1714 ELSE
1715 CA = 'CblasConjTrans'
1716 END IF
1717 IF (IORDER.EQ.1)THEN
1718 CRC = ' CblasRowMajor'
1719 ELSE
1720 CRC = ' CblasColMajor'
1721 END IF
1722 WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
1723 WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC
1724
1725 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
1726 9994 FORMAT( 20X, 2( I3, ',' ),
1727 $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' )
1728 END
1729 *
1730 SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1731 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1732 $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
1733 $ IORDER )
1734 *
1735 * Tests SSYR2K.
1736 *
1737 * Auxiliary routine for test program for Level 3 Blas.
1738 *
1739 * -- Written on 8-February-1989.
1740 * Jack Dongarra, Argonne National Laboratory.
1741 * Iain Duff, AERE Harwell.
1742 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1743 * Sven Hammarling, Numerical Algorithms Group Ltd.
1744 *
1745 * .. Parameters ..
1746 REAL ZERO
1747 PARAMETER ( ZERO = 0.0 )
1748 * .. Scalar Arguments ..
1749 REAL EPS, THRESH
1750 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1751 LOGICAL FATAL, REWI, TRACE
1752 CHARACTER*12 SNAME
1753 * .. Array Arguments ..
1754 REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1755 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1756 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1757 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1758 $ G( NMAX ), W( 2*NMAX )
1759 INTEGER IDIM( NIDIM )
1760 * .. Local Scalars ..
1761 REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1762 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1763 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1764 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1765 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1766 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1767 CHARACTER*2 ICHU
1768 CHARACTER*3 ICHT
1769 * .. Local Arrays ..
1770 LOGICAL ISAME( 13 )
1771 * .. External Functions ..
1772 LOGICAL LSE, LSERES
1773 EXTERNAL LSE, LSERES
1774 * .. External Subroutines ..
1775 EXTERNAL SMAKE, SMMCH, CSSYR2K
1776 * .. Intrinsic Functions ..
1777 INTRINSIC MAX
1778 * .. Scalars in Common ..
1779 INTEGER INFOT, NOUTC
1780 LOGICAL OK
1781 * .. Common blocks ..
1782 COMMON /INFOC/INFOT, NOUTC, OK
1783 * .. Data statements ..
1784 DATA ICHT/'NTC'/, ICHU/'UL'/
1785 * .. Executable Statements ..
1786 *
1787 NARGS = 12
1788 NC = 0
1789 RESET = .TRUE.
1790 ERRMAX = ZERO
1791 *
1792 DO 130 IN = 1, NIDIM
1793 N = IDIM( IN )
1794 * Set LDC to 1 more than minimum value if room.
1795 LDC = N
1796 IF( LDC.LT.NMAX )
1797 $ LDC = LDC + 1
1798 * Skip tests if not enough room.
1799 IF( LDC.GT.NMAX )
1800 $ GO TO 130
1801 LCC = LDC*N
1802 NULL = N.LE.0
1803 *
1804 DO 120 IK = 1, NIDIM
1805 K = IDIM( IK )
1806 *
1807 DO 110 ICT = 1, 3
1808 TRANS = ICHT( ICT: ICT )
1809 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
1810 IF( TRAN )THEN
1811 MA = K
1812 NA = N
1813 ELSE
1814 MA = N
1815 NA = K
1816 END IF
1817 * Set LDA to 1 more than minimum value if room.
1818 LDA = MA
1819 IF( LDA.LT.NMAX )
1820 $ LDA = LDA + 1
1821 * Skip tests if not enough room.
1822 IF( LDA.GT.NMAX )
1823 $ GO TO 110
1824 LAA = LDA*NA
1825 *
1826 * Generate the matrix A.
1827 *
1828 IF( TRAN )THEN
1829 CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA,
1830 $ LDA, RESET, ZERO )
1831 ELSE
1832 CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA,
1833 $ RESET, ZERO )
1834 END IF
1835 *
1836 * Generate the matrix B.
1837 *
1838 LDB = LDA
1839 LBB = LAA
1840 IF( TRAN )THEN
1841 CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ),
1842 $ 2*NMAX, BB, LDB, RESET, ZERO )
1843 ELSE
1844 CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ),
1845 $ NMAX, BB, LDB, RESET, ZERO )
1846 END IF
1847 *
1848 DO 100 ICU = 1, 2
1849 UPLO = ICHU( ICU: ICU )
1850 UPPER = UPLO.EQ.'U'
1851 *
1852 DO 90 IA = 1, NALF
1853 ALPHA = ALF( IA )
1854 *
1855 DO 80 IB = 1, NBET
1856 BETA = BET( IB )
1857 *
1858 * Generate the matrix C.
1859 *
1860 CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
1861 $ LDC, RESET, ZERO )
1862 *
1863 NC = NC + 1
1864 *
1865 * Save every datum before calling the subroutine.
1866 *
1867 UPLOS = UPLO
1868 TRANSS = TRANS
1869 NS = N
1870 KS = K
1871 ALS = ALPHA
1872 DO 10 I = 1, LAA
1873 AS( I ) = AA( I )
1874 10 CONTINUE
1875 LDAS = LDA
1876 DO 20 I = 1, LBB
1877 BS( I ) = BB( I )
1878 20 CONTINUE
1879 LDBS = LDB
1880 BETS = BETA
1881 DO 30 I = 1, LCC
1882 CS( I ) = CC( I )
1883 30 CONTINUE
1884 LDCS = LDC
1885 *
1886 * Call the subroutine.
1887 *
1888 IF( TRACE )
1889 $ CALL SPRCN5( NTRA, NC, SNAME, IORDER, UPLO,
1890 $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC)
1891 IF( REWI )
1892 $ REWIND NTRA
1893 CALL CSSYR2K( IORDER, UPLO, TRANS, N, K, ALPHA,
1894 $ AA, LDA, BB, LDB, BETA, CC, LDC )
1895 *
1896 * Check if error-exit was taken incorrectly.
1897 *
1898 IF( .NOT.OK )THEN
1899 WRITE( NOUT, FMT = 9993 )
1900 FATAL = .TRUE.
1901 GO TO 150
1902 END IF
1903 *
1904 * See what data changed inside subroutines.
1905 *
1906 ISAME( 1 ) = UPLOS.EQ.UPLO
1907 ISAME( 2 ) = TRANSS.EQ.TRANS
1908 ISAME( 3 ) = NS.EQ.N
1909 ISAME( 4 ) = KS.EQ.K
1910 ISAME( 5 ) = ALS.EQ.ALPHA
1911 ISAME( 6 ) = LSE( AS, AA, LAA )
1912 ISAME( 7 ) = LDAS.EQ.LDA
1913 ISAME( 8 ) = LSE( BS, BB, LBB )
1914 ISAME( 9 ) = LDBS.EQ.LDB
1915 ISAME( 10 ) = BETS.EQ.BETA
1916 IF( NULL )THEN
1917 ISAME( 11 ) = LSE( CS, CC, LCC )
1918 ELSE
1919 ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, CS,
1920 $ CC, LDC )
1921 END IF
1922 ISAME( 12 ) = LDCS.EQ.LDC
1923 *
1924 * If data was incorrectly changed, report and
1925 * return.
1926 *
1927 SAME = .TRUE.
1928 DO 40 I = 1, NARGS
1929 SAME = SAME.AND.ISAME( I )
1930 IF( .NOT.ISAME( I ) )
1931 $ WRITE( NOUT, FMT = 9998 )I+1
1932 40 CONTINUE
1933 IF( .NOT.SAME )THEN
1934 FATAL = .TRUE.
1935 GO TO 150
1936 END IF
1937 *
1938 IF( .NOT.NULL )THEN
1939 *
1940 * Check the result column by column.
1941 *
1942 JJAB = 1
1943 JC = 1
1944 DO 70 J = 1, N
1945 IF( UPPER )THEN
1946 JJ = 1
1947 LJ = J
1948 ELSE
1949 JJ = J
1950 LJ = N - J + 1
1951 END IF
1952 IF( TRAN )THEN
1953 DO 50 I = 1, K
1954 W( I ) = AB( ( J - 1 )*2*NMAX + K +
1955 $ I )
1956 W( K + I ) = AB( ( J - 1 )*2*NMAX +
1957 $ I )
1958 50 CONTINUE
1959 CALL SMMCH( 'T', 'N', LJ, 1, 2*K,
1960 $ ALPHA, AB( JJAB ), 2*NMAX,
1961 $ W, 2*NMAX, BETA,
1962 $ C( JJ, J ), NMAX, CT, G,
1963 $ CC( JC ), LDC, EPS, ERR,
1964 $ FATAL, NOUT, .TRUE. )
1965 ELSE
1966 DO 60 I = 1, K
1967 W( I ) = AB( ( K + I - 1 )*NMAX +
1968 $ J )
1969 W( K + I ) = AB( ( I - 1 )*NMAX +
1970 $ J )
1971 60 CONTINUE
1972 CALL SMMCH( 'N', 'N', LJ, 1, 2*K,
1973 $ ALPHA, AB( JJ ), NMAX, W,
1974 $ 2*NMAX, BETA, C( JJ, J ),
1975 $ NMAX, CT, G, CC( JC ), LDC,
1976 $ EPS, ERR, FATAL, NOUT,
1977 $ .TRUE. )
1978 END IF
1979 IF( UPPER )THEN
1980 JC = JC + LDC
1981 ELSE
1982 JC = JC + LDC + 1
1983 IF( TRAN )
1984 $ JJAB = JJAB + 2*NMAX
1985 END IF
1986 ERRMAX = MAX( ERRMAX, ERR )
1987 * If got really bad answer, report and
1988 * return.
1989 IF( FATAL )
1990 $ GO TO 140
1991 70 CONTINUE
1992 END IF
1993 *
1994 80 CONTINUE
1995 *
1996 90 CONTINUE
1997 *
1998 100 CONTINUE
1999 *
2000 110 CONTINUE
2001 *
2002 120 CONTINUE
2003 *
2004 130 CONTINUE
2005 *
2006 * Report result.
2007 *
2008 IF( ERRMAX.LT.THRESH )THEN
2009 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
2010 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
2011 ELSE
2012 IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
2013 IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
2014 END IF
2015 GO TO 160
2016 *
2017 140 CONTINUE
2018 IF( N.GT.1 )
2019 $ WRITE( NOUT, FMT = 9995 )J
2020 *
2021 150 CONTINUE
2022 WRITE( NOUT, FMT = 9996 )SNAME
2023 CALL SPRCN5( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA,
2024 $ LDA, LDB, BETA, LDC)
2025 *
2026 160 CONTINUE
2027 RETURN
2028 *
2029 10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2030 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2031 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
2032 10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2033 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2034 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
2035 10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2036 $ ' (', I6, ' CALL', 'S)' )
2037 10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2038 $ ' (', I6, ' CALL', 'S)' )
2039 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
2040 $ 'ANGED INCORRECTLY *******' )
2041 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
2042 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
2043 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
2044 $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
2045 $ ' .' )
2046 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2047 $ '******' )
2048 *
2049 * End of SCHK5.
2050 *
2051 END
2052 *
2053 SUBROUTINE SPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
2054 $ N, K, ALPHA, LDA, LDB, BETA, LDC)
2055 INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
2056 REAL ALPHA, BETA
2057 CHARACTER*1 UPLO, TRANSA
2058 CHARACTER*12 SNAME
2059 CHARACTER*14 CRC, CU, CA
2060
2061 IF (UPLO.EQ.'U')THEN
2062 CU = ' CblasUpper'
2063 ELSE
2064 CU = ' CblasLower'
2065 END IF
2066 IF (TRANSA.EQ.'N')THEN
2067 CA = ' CblasNoTrans'
2068 ELSE IF (TRANSA.EQ.'T')THEN
2069 CA = ' CblasTrans'
2070 ELSE
2071 CA = 'CblasConjTrans'
2072 END IF
2073 IF (IORDER.EQ.1)THEN
2074 CRC = ' CblasRowMajor'
2075 ELSE
2076 CRC = ' CblasColMajor'
2077 END IF
2078 WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
2079 WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
2080
2081 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
2082 9994 FORMAT( 20X, 2( I3, ',' ),
2083 $ F4.1, ', A,', I3, ', B', I3, ',', F4.1, ', C,', I3, ').' )
2084 END
2085 *
2086 SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
2087 $ TRANSL )
2088 *
2089 * Generates values for an M by N matrix A.
2090 * Stores the values in the array AA in the data structure required
2091 * by the routine, with unwanted elements set to rogue value.
2092 *
2093 * TYPE is 'GE', 'SY' or 'TR'.
2094 *
2095 * Auxiliary routine for test program for Level 3 Blas.
2096 *
2097 * -- Written on 8-February-1989.
2098 * Jack Dongarra, Argonne National Laboratory.
2099 * Iain Duff, AERE Harwell.
2100 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2101 * Sven Hammarling, Numerical Algorithms Group Ltd.
2102 *
2103 * .. Parameters ..
2104 REAL ZERO, ONE
2105 PARAMETER ( ZERO = 0.0, ONE = 1.0 )
2106 REAL ROGUE
2107 PARAMETER ( ROGUE = -1.0E10 )
2108 * .. Scalar Arguments ..
2109 REAL TRANSL
2110 INTEGER LDA, M, N, NMAX
2111 LOGICAL RESET
2112 CHARACTER*1 DIAG, UPLO
2113 CHARACTER*2 TYPE
2114 * .. Array Arguments ..
2115 REAL A( NMAX, * ), AA( * )
2116 * .. Local Scalars ..
2117 INTEGER I, IBEG, IEND, J
2118 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2119 * .. External Functions ..
2120 REAL SBEG
2121 EXTERNAL SBEG
2122 * .. Executable Statements ..
2123 GEN = TYPE.EQ.'GE'
2124 SYM = TYPE.EQ.'SY'
2125 TRI = TYPE.EQ.'TR'
2126 UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
2127 LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
2128 UNIT = TRI.AND.DIAG.EQ.'U'
2129 *
2130 * Generate data in array A.
2131 *
2132 DO 20 J = 1, N
2133 DO 10 I = 1, M
2134 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
2135 $ THEN
2136 A( I, J ) = SBEG( RESET ) + TRANSL
2137 IF( I.NE.J )THEN
2138 * Set some elements to zero
2139 IF( N.GT.3.AND.J.EQ.N/2 )
2140 $ A( I, J ) = ZERO
2141 IF( SYM )THEN
2142 A( J, I ) = A( I, J )
2143 ELSE IF( TRI )THEN
2144 A( J, I ) = ZERO
2145 END IF
2146 END IF
2147 END IF
2148 10 CONTINUE
2149 IF( TRI )
2150 $ A( J, J ) = A( J, J ) + ONE
2151 IF( UNIT )
2152 $ A( J, J ) = ONE
2153 20 CONTINUE
2154 *
2155 * Store elements in array AS in data structure required by routine.
2156 *
2157 IF( TYPE.EQ.'GE' )THEN
2158 DO 50 J = 1, N
2159 DO 30 I = 1, M
2160 AA( I + ( J - 1 )*LDA ) = A( I, J )
2161 30 CONTINUE
2162 DO 40 I = M + 1, LDA
2163 AA( I + ( J - 1 )*LDA ) = ROGUE
2164 40 CONTINUE
2165 50 CONTINUE
2166 ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
2167 DO 90 J = 1, N
2168 IF( UPPER )THEN
2169 IBEG = 1
2170 IF( UNIT )THEN
2171 IEND = J - 1
2172 ELSE
2173 IEND = J
2174 END IF
2175 ELSE
2176 IF( UNIT )THEN
2177 IBEG = J + 1
2178 ELSE
2179 IBEG = J
2180 END IF
2181 IEND = N
2182 END IF
2183 DO 60 I = 1, IBEG - 1
2184 AA( I + ( J - 1 )*LDA ) = ROGUE
2185 60 CONTINUE
2186 DO 70 I = IBEG, IEND
2187 AA( I + ( J - 1 )*LDA ) = A( I, J )
2188 70 CONTINUE
2189 DO 80 I = IEND + 1, LDA
2190 AA( I + ( J - 1 )*LDA ) = ROGUE
2191 80 CONTINUE
2192 90 CONTINUE
2193 END IF
2194 RETURN
2195 *
2196 * End of SMAKE.
2197 *
2198 END
2199 SUBROUTINE SMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
2200 $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
2201 $ NOUT, MV )
2202 *
2203 * Checks the results of the computational tests.
2204 *
2205 * Auxiliary routine for test program for Level 3 Blas.
2206 *
2207 * -- Written on 8-February-1989.
2208 * Jack Dongarra, Argonne National Laboratory.
2209 * Iain Duff, AERE Harwell.
2210 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2211 * Sven Hammarling, Numerical Algorithms Group Ltd.
2212 *
2213 * .. Parameters ..
2214 REAL ZERO, ONE
2215 PARAMETER ( ZERO = 0.0, ONE = 1.0 )
2216 * .. Scalar Arguments ..
2217 REAL ALPHA, BETA, EPS, ERR
2218 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
2219 LOGICAL FATAL, MV
2220 CHARACTER*1 TRANSA, TRANSB
2221 * .. Array Arguments ..
2222 REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
2223 $ CC( LDCC, * ), CT( * ), G( * )
2224 * .. Local Scalars ..
2225 REAL ERRI
2226 INTEGER I, J, K
2227 LOGICAL TRANA, TRANB
2228 * .. Intrinsic Functions ..
2229 INTRINSIC ABS, MAX, SQRT
2230 * .. Executable Statements ..
2231 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
2232 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
2233 *
2234 * Compute expected result, one column at a time, in CT using data
2235 * in A, B and C.
2236 * Compute gauges in G.
2237 *
2238 DO 120 J = 1, N
2239 *
2240 DO 10 I = 1, M
2241 CT( I ) = ZERO
2242 G( I ) = ZERO
2243 10 CONTINUE
2244 IF( .NOT.TRANA.AND..NOT.TRANB )THEN
2245 DO 30 K = 1, KK
2246 DO 20 I = 1, M
2247 CT( I ) = CT( I ) + A( I, K )*B( K, J )
2248 G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) )
2249 20 CONTINUE
2250 30 CONTINUE
2251 ELSE IF( TRANA.AND..NOT.TRANB )THEN
2252 DO 50 K = 1, KK
2253 DO 40 I = 1, M
2254 CT( I ) = CT( I ) + A( K, I )*B( K, J )
2255 G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) )
2256 40 CONTINUE
2257 50 CONTINUE
2258 ELSE IF( .NOT.TRANA.AND.TRANB )THEN
2259 DO 70 K = 1, KK
2260 DO 60 I = 1, M
2261 CT( I ) = CT( I ) + A( I, K )*B( J, K )
2262 G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) )
2263 60 CONTINUE
2264 70 CONTINUE
2265 ELSE IF( TRANA.AND.TRANB )THEN
2266 DO 90 K = 1, KK
2267 DO 80 I = 1, M
2268 CT( I ) = CT( I ) + A( K, I )*B( J, K )
2269 G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) )
2270 80 CONTINUE
2271 90 CONTINUE
2272 END IF
2273 DO 100 I = 1, M
2274 CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
2275 G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) )
2276 100 CONTINUE
2277 *
2278 * Compute the error ratio for this result.
2279 *
2280 ERR = ZERO
2281 DO 110 I = 1, M
2282 ERRI = ABS( CT( I ) - CC( I, J ) )/EPS
2283 IF( G( I ).NE.ZERO )
2284 $ ERRI = ERRI/G( I )
2285 ERR = MAX( ERR, ERRI )
2286 IF( ERR*SQRT( EPS ).GE.ONE )
2287 $ GO TO 130
2288 110 CONTINUE
2289 *
2290 120 CONTINUE
2291 *
2292 * If the loop completes, all results are at least half accurate.
2293 GO TO 150
2294 *
2295 * Report fatal error.
2296 *
2297 130 FATAL = .TRUE.
2298 WRITE( NOUT, FMT = 9999 )
2299 DO 140 I = 1, M
2300 IF( MV )THEN
2301 WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
2302 ELSE
2303 WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
2304 END IF
2305 140 CONTINUE
2306 IF( N.GT.1 )
2307 $ WRITE( NOUT, FMT = 9997 )J
2308 *
2309 150 CONTINUE
2310 RETURN
2311 *
2312 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2313 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2314 $ 'TED RESULT' )
2315 9998 FORMAT( 1X, I7, 2G18.6 )
2316 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
2317 *
2318 * End of SMMCH.
2319 *
2320 END
2321 LOGICAL FUNCTION LSE( RI, RJ, LR )
2322 *
2323 * Tests if two arrays are identical.
2324 *
2325 * Auxiliary routine for test program for Level 3 Blas.
2326 *
2327 * -- Written on 8-February-1989.
2328 * Jack Dongarra, Argonne National Laboratory.
2329 * Iain Duff, AERE Harwell.
2330 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2331 * Sven Hammarling, Numerical Algorithms Group Ltd.
2332 *
2333 * .. Scalar Arguments ..
2334 INTEGER LR
2335 * .. Array Arguments ..
2336 REAL RI( * ), RJ( * )
2337 * .. Local Scalars ..
2338 INTEGER I
2339 * .. Executable Statements ..
2340 DO 10 I = 1, LR
2341 IF( RI( I ).NE.RJ( I ) )
2342 $ GO TO 20
2343 10 CONTINUE
2344 LSE = .TRUE.
2345 GO TO 30
2346 20 CONTINUE
2347 LSE = .FALSE.
2348 30 RETURN
2349 *
2350 * End of LSE.
2351 *
2352 END
2353 LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA )
2354 *
2355 * Tests if selected elements in two arrays are equal.
2356 *
2357 * TYPE is 'GE' or 'SY'.
2358 *
2359 * Auxiliary routine for test program for Level 3 Blas.
2360 *
2361 * -- Written on 8-February-1989.
2362 * Jack Dongarra, Argonne National Laboratory.
2363 * Iain Duff, AERE Harwell.
2364 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2365 * Sven Hammarling, Numerical Algorithms Group Ltd.
2366 *
2367 * .. Scalar Arguments ..
2368 INTEGER LDA, M, N
2369 CHARACTER*1 UPLO
2370 CHARACTER*2 TYPE
2371 * .. Array Arguments ..
2372 REAL AA( LDA, * ), AS( LDA, * )
2373 * .. Local Scalars ..
2374 INTEGER I, IBEG, IEND, J
2375 LOGICAL UPPER
2376 * .. Executable Statements ..
2377 UPPER = UPLO.EQ.'U'
2378 IF( TYPE.EQ.'GE' )THEN
2379 DO 20 J = 1, N
2380 DO 10 I = M + 1, LDA
2381 IF( AA( I, J ).NE.AS( I, J ) )
2382 $ GO TO 70
2383 10 CONTINUE
2384 20 CONTINUE
2385 ELSE IF( TYPE.EQ.'SY' )THEN
2386 DO 50 J = 1, N
2387 IF( UPPER )THEN
2388 IBEG = 1
2389 IEND = J
2390 ELSE
2391 IBEG = J
2392 IEND = N
2393 END IF
2394 DO 30 I = 1, IBEG - 1
2395 IF( AA( I, J ).NE.AS( I, J ) )
2396 $ GO TO 70
2397 30 CONTINUE
2398 DO 40 I = IEND + 1, LDA
2399 IF( AA( I, J ).NE.AS( I, J ) )
2400 $ GO TO 70
2401 40 CONTINUE
2402 50 CONTINUE
2403 END IF
2404 *
2405 60 CONTINUE
2406 LSERES = .TRUE.
2407 GO TO 80
2408 70 CONTINUE
2409 LSERES = .FALSE.
2410 80 RETURN
2411 *
2412 * End of LSERES.
2413 *
2414 END
2415 REAL FUNCTION SBEG( RESET )
2416 *
2417 * Generates random numbers uniformly distributed between -0.5 and 0.5.
2418 *
2419 * Auxiliary routine for test program for Level 3 Blas.
2420 *
2421 * -- Written on 8-February-1989.
2422 * Jack Dongarra, Argonne National Laboratory.
2423 * Iain Duff, AERE Harwell.
2424 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2425 * Sven Hammarling, Numerical Algorithms Group Ltd.
2426 *
2427 * .. Scalar Arguments ..
2428 LOGICAL RESET
2429 * .. Local Scalars ..
2430 INTEGER I, IC, MI
2431 * .. Save statement ..
2432 SAVE I, IC, MI
2433 * .. Executable Statements ..
2434 IF( RESET )THEN
2435 * Initialize local variables.
2436 MI = 891
2437 I = 7
2438 IC = 0
2439 RESET = .FALSE.
2440 END IF
2441 *
2442 * The sequence of values of I is bounded between 1 and 999.
2443 * If initial I = 1,2,3,6,7 or 9, the period will be 50.
2444 * If initial I = 4 or 8, the period will be 25.
2445 * If initial I = 5, the period will be 10.
2446 * IC is used to break up the period by skipping 1 value of I in 6.
2447 *
2448 IC = IC + 1
2449 10 I = I*MI
2450 I = I - 1000*( I/1000 )
2451 IF( IC.GE.5 )THEN
2452 IC = 0
2453 GO TO 10
2454 END IF
2455 SBEG = ( I - 500 )/1001.0
2456 RETURN
2457 *
2458 * End of SBEG.
2459 *
2460 END
2461 REAL FUNCTION SDIFF( X, Y )
2462 *
2463 * Auxiliary routine for test program for Level 3 Blas.
2464 *
2465 * -- Written on 8-February-1989.
2466 * Jack Dongarra, Argonne National Laboratory.
2467 * Iain Duff, AERE Harwell.
2468 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2469 * Sven Hammarling, Numerical Algorithms Group Ltd.
2470 *
2471 * .. Scalar Arguments ..
2472 REAL X, Y
2473 * .. Executable Statements ..
2474 SDIFF = X - Y
2475 RETURN
2476 *
2477 * End of SDIFF.
2478 *
2479 END