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