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