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 14 records
6 * of the file are read using list-directed input, the last 9 records
7 * are read using the format ( A6, L2 ). An annotated example of a data
8 * file can be obtained by deleting the first 3 characters from the
9 * following 23 lines:
10 * 'ZBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE
11 * 6 UNIT NUMBER OF SUMMARY FILE
12 * 'ZBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
13 * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
14 * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
15 * F LOGICAL FLAG, T TO STOP ON FAILURES.
16 * T LOGICAL FLAG, T TO TEST ERROR EXITS.
17 * 16.0 THRESHOLD VALUE OF TEST RATIO
18 * 6 NUMBER OF VALUES OF N
19 * 0 1 2 3 5 9 VALUES OF N
20 * 3 NUMBER OF VALUES OF ALPHA
21 * (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
22 * 3 NUMBER OF VALUES OF BETA
23 * (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
24 * ZGEMM T PUT F FOR NO TEST. SAME COLUMNS.
25 * ZHEMM T PUT F FOR NO TEST. SAME COLUMNS.
26 * ZSYMM T PUT F FOR NO TEST. SAME COLUMNS.
27 * ZTRMM T PUT F FOR NO TEST. SAME COLUMNS.
28 * ZTRSM T PUT F FOR NO TEST. SAME COLUMNS.
29 * ZHERK T PUT F FOR NO TEST. SAME COLUMNS.
30 * ZSYRK T PUT F FOR NO TEST. SAME COLUMNS.
31 * ZHER2K T PUT F FOR NO TEST. SAME COLUMNS.
32 * ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
33 *
34 * See:
35 *
36 * Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
37 * A Set of Level 3 Basic Linear Algebra Subprograms.
38 *
39 * Technical Memorandum No.88 (Revision 1), Mathematics and
40 * Computer Science Division, Argonne National Laboratory, 9700
41 * South Cass Avenue, Argonne, Illinois 60439, US.
42 *
43 * -- Written on 8-February-1989.
44 * Jack Dongarra, Argonne National Laboratory.
45 * Iain Duff, AERE Harwell.
46 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
47 * Sven Hammarling, Numerical Algorithms Group Ltd.
48 *
49 * .. Parameters ..
50 INTEGER NIN
51 PARAMETER ( NIN = 5 )
52 INTEGER NSUBS
53 PARAMETER ( NSUBS = 9 )
54 COMPLEX*16 ZERO, ONE
55 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ),
56 $ ONE = ( 1.0D0, 0.0D0 ) )
57 DOUBLE PRECISION RZERO, RHALF, RONE
58 PARAMETER ( RZERO = 0.0D0, RHALF = 0.5D0, RONE = 1.0D0 )
59 INTEGER NMAX
60 PARAMETER ( NMAX = 65 )
61 INTEGER NIDMAX, NALMAX, NBEMAX
62 PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 )
63 * .. Local Scalars ..
64 DOUBLE PRECISION EPS, ERR, THRESH
65 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA
66 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
67 $ TSTERR
68 CHARACTER*1 TRANSA, TRANSB
69 CHARACTER*6 SNAMET
70 CHARACTER*32 SNAPS, SUMMRY
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*6 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, ZCHKE, ZMMCH
88 * .. Intrinsic Functions ..
89 INTRINSIC MAX, MIN
90 * .. Scalars in Common ..
91 INTEGER INFOT, NOUTC
92 LOGICAL LERR, OK
93 CHARACTER*6 SRNAMT
94 * .. Common blocks ..
95 COMMON /INFOC/INFOT, NOUTC, OK, LERR
96 COMMON /SRNAMC/SRNAMT
97 * .. Data statements ..
98 DATA SNAMES/'ZGEMM ', 'ZHEMM ', 'ZSYMM ', 'ZTRMM ',
99 $ 'ZTRSM ', 'ZHERK ', 'ZSYRK ', 'ZHER2K',
100 $ 'ZSYR2K'/
101 * .. Executable Statements ..
102 *
103 * Read name and unit number for summary output file and open file.
104 *
105 READ( NIN, FMT = * )SUMMRY
106 READ( NIN, FMT = * )NOUT
107 OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
108 NOUTC = NOUT
109 *
110 * Read name and unit number for snapshot output file and open file.
111 *
112 READ( NIN, FMT = * )SNAPS
113 READ( NIN, FMT = * )NTRA
114 TRACE = NTRA.GE.0
115 IF( TRACE )THEN
116 OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
117 END IF
118 * Read the flag that directs rewinding of the snapshot file.
119 READ( NIN, FMT = * )REWI
120 REWI = REWI.AND.TRACE
121 * Read the flag that directs stopping on any failure.
122 READ( NIN, FMT = * )SFATAL
123 * Read the flag that indicates whether error exits are to be tested.
124 READ( NIN, FMT = * )TSTERR
125 * Read the threshold value of the test ratio
126 READ( NIN, FMT = * )THRESH
127 *
128 * Read and check the parameter values for the tests.
129 *
130 * Values of N
131 READ( NIN, FMT = * )NIDIM
132 IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
133 WRITE( NOUT, FMT = 9997 )'N', NIDMAX
134 GO TO 220
135 END IF
136 READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
137 DO 10 I = 1, NIDIM
138 IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
139 WRITE( NOUT, FMT = 9996 )NMAX
140 GO TO 220
141 END IF
142 10 CONTINUE
143 * Values of ALPHA
144 READ( NIN, FMT = * )NALF
145 IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
146 WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
147 GO TO 220
148 END IF
149 READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
150 * Values of BETA
151 READ( NIN, FMT = * )NBET
152 IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
153 WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
154 GO TO 220
155 END IF
156 READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
157 *
158 * Report values of parameters.
159 *
160 WRITE( NOUT, FMT = 9995 )
161 WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM )
162 WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF )
163 WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET )
164 IF( .NOT.TSTERR )THEN
165 WRITE( NOUT, FMT = * )
166 WRITE( NOUT, FMT = 9984 )
167 END IF
168 WRITE( NOUT, FMT = * )
169 WRITE( NOUT, FMT = 9999 )THRESH
170 WRITE( NOUT, FMT = * )
171 *
172 * Read names of subroutines and flags which indicate
173 * whether they are to be tested.
174 *
175 DO 20 I = 1, NSUBS
176 LTEST( I ) = .FALSE.
177 20 CONTINUE
178 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT
179 DO 40 I = 1, NSUBS
180 IF( SNAMET.EQ.SNAMES( I ) )
181 $ GO TO 50
182 40 CONTINUE
183 WRITE( NOUT, FMT = 9990 )SNAMET
184 STOP
185 50 LTEST( I ) = LTESTT
186 GO TO 30
187 *
188 60 CONTINUE
189 CLOSE ( NIN )
190 *
191 * Compute EPS (the machine precision).
192 *
193 EPS = RONE
194 70 CONTINUE
195 IF( DDIFF( RONE + EPS, RONE ).EQ.RZERO )
196 $ GO TO 80
197 EPS = RHALF*EPS
198 GO TO 70
199 80 CONTINUE
200 EPS = EPS + EPS
201 WRITE( NOUT, FMT = 9998 )EPS
202 *
203 * Check the reliability of ZMMCH using exact data.
204 *
205 N = MIN( 32, NMAX )
206 DO 100 J = 1, N
207 DO 90 I = 1, N
208 AB( I, J ) = MAX( I - J + 1, 0 )
209 90 CONTINUE
210 AB( J, NMAX + 1 ) = J
211 AB( 1, NMAX + J ) = J
212 C( J, 1 ) = ZERO
213 100 CONTINUE
214 DO 110 J = 1, N
215 CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
216 110 CONTINUE
217 * CC holds the exact result. On exit from ZMMCH CT holds
218 * the result computed by ZMMCH.
219 TRANSA = 'N'
220 TRANSB = 'N'
221 CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
222 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
223 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
224 SAME = LZE( CC, CT, N )
225 IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
226 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
227 STOP
228 END IF
229 TRANSB = 'C'
230 CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
231 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
232 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
233 SAME = LZE( CC, CT, N )
234 IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
235 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
236 STOP
237 END IF
238 DO 120 J = 1, N
239 AB( J, NMAX + 1 ) = N - J + 1
240 AB( 1, NMAX + J ) = N - J + 1
241 120 CONTINUE
242 DO 130 J = 1, N
243 CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 -
244 $ ( ( J + 1 )*J*( J - 1 ) )/3
245 130 CONTINUE
246 TRANSA = 'C'
247 TRANSB = 'N'
248 CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
249 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
250 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
251 SAME = LZE( CC, CT, N )
252 IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
253 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
254 STOP
255 END IF
256 TRANSB = 'C'
257 CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
258 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
259 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
260 SAME = LZE( CC, CT, N )
261 IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
262 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
263 STOP
264 END IF
265 *
266 * Test each subroutine in turn.
267 *
268 DO 200 ISNUM = 1, NSUBS
269 WRITE( NOUT, FMT = * )
270 IF( .NOT.LTEST( ISNUM ) )THEN
271 * Subprogram is not to be tested.
272 WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM )
273 ELSE
274 SRNAMT = SNAMES( ISNUM )
275 * Test error exits.
276 IF( TSTERR )THEN
277 CALL ZCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
278 WRITE( NOUT, FMT = * )
279 END IF
280 * Test computations.
281 INFOT = 0
282 OK = .TRUE.
283 FATAL = .FALSE.
284 GO TO ( 140, 150, 150, 160, 160, 170, 170,
285 $ 180, 180 )ISNUM
286 * Test ZGEMM, 01.
287 140 CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
288 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
289 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
290 $ CC, CS, CT, G )
291 GO TO 190
292 * Test ZHEMM, 02, ZSYMM, 03.
293 150 CALL ZCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
294 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
295 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
296 $ CC, CS, CT, G )
297 GO TO 190
298 * Test ZTRMM, 04, ZTRSM, 05.
299 160 CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
300 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
301 $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C )
302 GO TO 190
303 * Test ZHERK, 06, ZSYRK, 07.
304 170 CALL ZCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
305 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
306 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
307 $ CC, CS, CT, G )
308 GO TO 190
309 * Test ZHER2K, 08, ZSYR2K, 09.
310 180 CALL ZCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
311 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
312 $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
313 GO TO 190
314 *
315 190 IF( FATAL.AND.SFATAL )
316 $ GO TO 210
317 END IF
318 200 CONTINUE
319 WRITE( NOUT, FMT = 9986 )
320 GO TO 230
321 *
322 210 CONTINUE
323 WRITE( NOUT, FMT = 9985 )
324 GO TO 230
325 *
326 220 CONTINUE
327 WRITE( NOUT, FMT = 9991 )
328 *
329 230 CONTINUE
330 IF( TRACE )
331 $ CLOSE ( NTRA )
332 CLOSE ( NOUT )
333 STOP
334 *
335 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
336 $ 'S THAN', F8.2 )
337 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
338 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
339 $ 'THAN ', I2 )
340 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
341 9995 FORMAT( ' TESTS OF THE COMPLEX*16 LEVEL 3 BLAS', //' THE F',
342 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
343 9994 FORMAT( ' FOR N ', 9I6 )
344 9993 FORMAT( ' FOR ALPHA ',
345 $ 7( '(', F4.1, ',', F4.1, ') ', : ) )
346 9992 FORMAT( ' FOR BETA ',
347 $ 7( '(', F4.1, ',', F4.1, ') ', : ) )
348 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
349 $ /' ******* TESTS ABANDONED *******' )
350 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
351 $ 'ESTS ABANDONED *******' )
352 9989 FORMAT( ' ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
353 $ 'ATED WRONGLY.', /' ZMMCH WAS CALLED WITH TRANSA = ', A1,
354 $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',
355 $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
356 $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
357 $ '*******' )
358 9988 FORMAT( A6, L2 )
359 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' )
360 9986 FORMAT( /' END OF TESTS' )
361 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
362 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
363 *
364 * End of ZBLAT3.
365 *
366 END
367 SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
368 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
369 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
370 *
371 * Tests ZGEMM.
372 *
373 * Auxiliary routine for test program for Level 3 Blas.
374 *
375 * -- Written on 8-February-1989.
376 * Jack Dongarra, Argonne National Laboratory.
377 * Iain Duff, AERE Harwell.
378 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
379 * Sven Hammarling, Numerical Algorithms Group Ltd.
380 *
381 * .. Parameters ..
382 COMPLEX*16 ZERO
383 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) )
384 DOUBLE PRECISION RZERO
385 PARAMETER ( RZERO = 0.0D0 )
386 * .. Scalar Arguments ..
387 DOUBLE PRECISION EPS, THRESH
388 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
389 LOGICAL FATAL, REWI, TRACE
390 CHARACTER*6 SNAME
391 * .. Array Arguments ..
392 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
393 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
394 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
395 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
396 $ CS( NMAX*NMAX ), CT( NMAX )
397 DOUBLE PRECISION G( NMAX )
398 INTEGER IDIM( NIDIM )
399 * .. Local Scalars ..
400 COMPLEX*16 ALPHA, ALS, BETA, BLS
401 DOUBLE PRECISION ERR, ERRMAX
402 INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
403 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
404 $ MA, MB, MS, N, NA, NARGS, NB, NC, NS
405 LOGICAL NULL, RESET, SAME, TRANA, TRANB
406 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
407 CHARACTER*3 ICH
408 * .. Local Arrays ..
409 LOGICAL ISAME( 13 )
410 * .. External Functions ..
411 LOGICAL LZE, LZERES
412 EXTERNAL LZE, LZERES
413 * .. External Subroutines ..
414 EXTERNAL ZGEMM, ZMAKE, ZMMCH
415 * .. Intrinsic Functions ..
416 INTRINSIC MAX
417 * .. Scalars in Common ..
418 INTEGER INFOT, NOUTC
419 LOGICAL LERR, OK
420 * .. Common blocks ..
421 COMMON /INFOC/INFOT, NOUTC, OK, LERR
422 * .. Data statements ..
423 DATA ICH/'NTC'/
424 * .. Executable Statements ..
425 *
426 NARGS = 13
427 NC = 0
428 RESET = .TRUE.
429 ERRMAX = RZERO
430 *
431 DO 110 IM = 1, NIDIM
432 M = IDIM( IM )
433 *
434 DO 100 IN = 1, NIDIM
435 N = IDIM( IN )
436 * Set LDC to 1 more than minimum value if room.
437 LDC = M
438 IF( LDC.LT.NMAX )
439 $ LDC = LDC + 1
440 * Skip tests if not enough room.
441 IF( LDC.GT.NMAX )
442 $ GO TO 100
443 LCC = LDC*N
444 NULL = N.LE.0.OR.M.LE.0
445 *
446 DO 90 IK = 1, NIDIM
447 K = IDIM( IK )
448 *
449 DO 80 ICA = 1, 3
450 TRANSA = ICH( ICA: ICA )
451 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
452 *
453 IF( TRANA )THEN
454 MA = K
455 NA = M
456 ELSE
457 MA = M
458 NA = K
459 END IF
460 * Set LDA to 1 more than minimum value if room.
461 LDA = MA
462 IF( LDA.LT.NMAX )
463 $ LDA = LDA + 1
464 * Skip tests if not enough room.
465 IF( LDA.GT.NMAX )
466 $ GO TO 80
467 LAA = LDA*NA
468 *
469 * Generate the matrix A.
470 *
471 CALL ZMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
472 $ RESET, ZERO )
473 *
474 DO 70 ICB = 1, 3
475 TRANSB = ICH( ICB: ICB )
476 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
477 *
478 IF( TRANB )THEN
479 MB = N
480 NB = K
481 ELSE
482 MB = K
483 NB = N
484 END IF
485 * Set LDB to 1 more than minimum value if room.
486 LDB = MB
487 IF( LDB.LT.NMAX )
488 $ LDB = LDB + 1
489 * Skip tests if not enough room.
490 IF( LDB.GT.NMAX )
491 $ GO TO 70
492 LBB = LDB*NB
493 *
494 * Generate the matrix B.
495 *
496 CALL ZMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB,
497 $ LDB, RESET, ZERO )
498 *
499 DO 60 IA = 1, NALF
500 ALPHA = ALF( IA )
501 *
502 DO 50 IB = 1, NBET
503 BETA = BET( IB )
504 *
505 * Generate the matrix C.
506 *
507 CALL ZMAKE( 'GE', ' ', ' ', M, N, C, NMAX,
508 $ CC, LDC, RESET, ZERO )
509 *
510 NC = NC + 1
511 *
512 * Save every datum before calling the
513 * subroutine.
514 *
515 TRANAS = TRANSA
516 TRANBS = TRANSB
517 MS = M
518 NS = N
519 KS = K
520 ALS = ALPHA
521 DO 10 I = 1, LAA
522 AS( I ) = AA( I )
523 10 CONTINUE
524 LDAS = LDA
525 DO 20 I = 1, LBB
526 BS( I ) = BB( I )
527 20 CONTINUE
528 LDBS = LDB
529 BLS = BETA
530 DO 30 I = 1, LCC
531 CS( I ) = CC( I )
532 30 CONTINUE
533 LDCS = LDC
534 *
535 * Call the subroutine.
536 *
537 IF( TRACE )
538 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
539 $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB,
540 $ BETA, LDC
541 IF( REWI )
542 $ REWIND NTRA
543 CALL ZGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
544 $ AA, LDA, BB, LDB, BETA, CC, LDC )
545 *
546 * Check if error-exit was taken incorrectly.
547 *
548 IF( .NOT.OK )THEN
549 WRITE( NOUT, FMT = 9994 )
550 FATAL = .TRUE.
551 GO TO 120
552 END IF
553 *
554 * See what data changed inside subroutines.
555 *
556 ISAME( 1 ) = TRANSA.EQ.TRANAS
557 ISAME( 2 ) = TRANSB.EQ.TRANBS
558 ISAME( 3 ) = MS.EQ.M
559 ISAME( 4 ) = NS.EQ.N
560 ISAME( 5 ) = KS.EQ.K
561 ISAME( 6 ) = ALS.EQ.ALPHA
562 ISAME( 7 ) = LZE( AS, AA, LAA )
563 ISAME( 8 ) = LDAS.EQ.LDA
564 ISAME( 9 ) = LZE( BS, BB, LBB )
565 ISAME( 10 ) = LDBS.EQ.LDB
566 ISAME( 11 ) = BLS.EQ.BETA
567 IF( NULL )THEN
568 ISAME( 12 ) = LZE( CS, CC, LCC )
569 ELSE
570 ISAME( 12 ) = LZERES( 'GE', ' ', M, N, CS,
571 $ CC, LDC )
572 END IF
573 ISAME( 13 ) = LDCS.EQ.LDC
574 *
575 * If data was incorrectly changed, report
576 * and return.
577 *
578 SAME = .TRUE.
579 DO 40 I = 1, NARGS
580 SAME = SAME.AND.ISAME( I )
581 IF( .NOT.ISAME( I ) )
582 $ WRITE( NOUT, FMT = 9998 )I
583 40 CONTINUE
584 IF( .NOT.SAME )THEN
585 FATAL = .TRUE.
586 GO TO 120
587 END IF
588 *
589 IF( .NOT.NULL )THEN
590 *
591 * Check the result.
592 *
593 CALL ZMMCH( TRANSA, TRANSB, M, N, K,
594 $ ALPHA, A, NMAX, B, NMAX, BETA,
595 $ C, NMAX, CT, G, CC, LDC, EPS,
596 $ ERR, FATAL, NOUT, .TRUE. )
597 ERRMAX = MAX( ERRMAX, ERR )
598 * If got really bad answer, report and
599 * return.
600 IF( FATAL )
601 $ GO TO 120
602 END IF
603 *
604 50 CONTINUE
605 *
606 60 CONTINUE
607 *
608 70 CONTINUE
609 *
610 80 CONTINUE
611 *
612 90 CONTINUE
613 *
614 100 CONTINUE
615 *
616 110 CONTINUE
617 *
618 * Report result.
619 *
620 IF( ERRMAX.LT.THRESH )THEN
621 WRITE( NOUT, FMT = 9999 )SNAME, NC
622 ELSE
623 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
624 END IF
625 GO TO 130
626 *
627 120 CONTINUE
628 WRITE( NOUT, FMT = 9996 )SNAME
629 WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K,
630 $ ALPHA, LDA, LDB, BETA, LDC
631 *
632 130 CONTINUE
633 RETURN
634 *
635 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
636 $ 'S)' )
637 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
638 $ 'ANGED INCORRECTLY *******' )
639 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
640 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
641 $ ' - SUSPECT *******' )
642 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
643 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',',
644 $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
645 $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
646 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
647 $ '******' )
648 *
649 * End of ZCHK1.
650 *
651 END
652 SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
653 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
654 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
655 *
656 * Tests ZHEMM and ZSYMM.
657 *
658 * Auxiliary routine for test program for Level 3 Blas.
659 *
660 * -- Written on 8-February-1989.
661 * Jack Dongarra, Argonne National Laboratory.
662 * Iain Duff, AERE Harwell.
663 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
664 * Sven Hammarling, Numerical Algorithms Group Ltd.
665 *
666 * .. Parameters ..
667 COMPLEX*16 ZERO
668 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) )
669 DOUBLE PRECISION RZERO
670 PARAMETER ( RZERO = 0.0D0 )
671 * .. Scalar Arguments ..
672 DOUBLE PRECISION EPS, THRESH
673 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
674 LOGICAL FATAL, REWI, TRACE
675 CHARACTER*6 SNAME
676 * .. Array Arguments ..
677 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
678 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
679 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
680 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
681 $ CS( NMAX*NMAX ), CT( NMAX )
682 DOUBLE PRECISION G( NMAX )
683 INTEGER IDIM( NIDIM )
684 * .. Local Scalars ..
685 COMPLEX*16 ALPHA, ALS, BETA, BLS
686 DOUBLE PRECISION ERR, ERRMAX
687 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
688 $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
689 $ NARGS, NC, NS
690 LOGICAL CONJ, LEFT, NULL, RESET, SAME
691 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
692 CHARACTER*2 ICHS, ICHU
693 * .. Local Arrays ..
694 LOGICAL ISAME( 13 )
695 * .. External Functions ..
696 LOGICAL LZE, LZERES
697 EXTERNAL LZE, LZERES
698 * .. External Subroutines ..
699 EXTERNAL ZHEMM, ZMAKE, ZMMCH, ZSYMM
700 * .. Intrinsic Functions ..
701 INTRINSIC MAX
702 * .. Scalars in Common ..
703 INTEGER INFOT, NOUTC
704 LOGICAL LERR, OK
705 * .. Common blocks ..
706 COMMON /INFOC/INFOT, NOUTC, OK, LERR
707 * .. Data statements ..
708 DATA ICHS/'LR'/, ICHU/'UL'/
709 * .. Executable Statements ..
710 CONJ = SNAME( 2: 3 ).EQ.'HE'
711 *
712 NARGS = 12
713 NC = 0
714 RESET = .TRUE.
715 ERRMAX = RZERO
716 *
717 DO 100 IM = 1, NIDIM
718 M = IDIM( IM )
719 *
720 DO 90 IN = 1, NIDIM
721 N = IDIM( IN )
722 * Set LDC to 1 more than minimum value if room.
723 LDC = M
724 IF( LDC.LT.NMAX )
725 $ LDC = LDC + 1
726 * Skip tests if not enough room.
727 IF( LDC.GT.NMAX )
728 $ GO TO 90
729 LCC = LDC*N
730 NULL = N.LE.0.OR.M.LE.0
731 * Set LDB to 1 more than minimum value if room.
732 LDB = M
733 IF( LDB.LT.NMAX )
734 $ LDB = LDB + 1
735 * Skip tests if not enough room.
736 IF( LDB.GT.NMAX )
737 $ GO TO 90
738 LBB = LDB*N
739 *
740 * Generate the matrix B.
741 *
742 CALL ZMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET,
743 $ ZERO )
744 *
745 DO 80 ICS = 1, 2
746 SIDE = ICHS( ICS: ICS )
747 LEFT = SIDE.EQ.'L'
748 *
749 IF( LEFT )THEN
750 NA = M
751 ELSE
752 NA = N
753 END IF
754 * Set LDA to 1 more than minimum value if room.
755 LDA = NA
756 IF( LDA.LT.NMAX )
757 $ LDA = LDA + 1
758 * Skip tests if not enough room.
759 IF( LDA.GT.NMAX )
760 $ GO TO 80
761 LAA = LDA*NA
762 *
763 DO 70 ICU = 1, 2
764 UPLO = ICHU( ICU: ICU )
765 *
766 * Generate the hermitian or symmetric matrix A.
767 *
768 CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', NA, NA, A, NMAX,
769 $ AA, LDA, RESET, ZERO )
770 *
771 DO 60 IA = 1, NALF
772 ALPHA = ALF( IA )
773 *
774 DO 50 IB = 1, NBET
775 BETA = BET( IB )
776 *
777 * Generate the matrix C.
778 *
779 CALL ZMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC,
780 $ LDC, RESET, ZERO )
781 *
782 NC = NC + 1
783 *
784 * Save every datum before calling the
785 * subroutine.
786 *
787 SIDES = SIDE
788 UPLOS = UPLO
789 MS = M
790 NS = N
791 ALS = ALPHA
792 DO 10 I = 1, LAA
793 AS( I ) = AA( I )
794 10 CONTINUE
795 LDAS = LDA
796 DO 20 I = 1, LBB
797 BS( I ) = BB( I )
798 20 CONTINUE
799 LDBS = LDB
800 BLS = BETA
801 DO 30 I = 1, LCC
802 CS( I ) = CC( I )
803 30 CONTINUE
804 LDCS = LDC
805 *
806 * Call the subroutine.
807 *
808 IF( TRACE )
809 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE,
810 $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC
811 IF( REWI )
812 $ REWIND NTRA
813 IF( CONJ )THEN
814 CALL ZHEMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
815 $ BB, LDB, BETA, CC, LDC )
816 ELSE
817 CALL ZSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
818 $ BB, LDB, BETA, CC, LDC )
819 END IF
820 *
821 * Check if error-exit was taken incorrectly.
822 *
823 IF( .NOT.OK )THEN
824 WRITE( NOUT, FMT = 9994 )
825 FATAL = .TRUE.
826 GO TO 110
827 END IF
828 *
829 * See what data changed inside subroutines.
830 *
831 ISAME( 1 ) = SIDES.EQ.SIDE
832 ISAME( 2 ) = UPLOS.EQ.UPLO
833 ISAME( 3 ) = MS.EQ.M
834 ISAME( 4 ) = NS.EQ.N
835 ISAME( 5 ) = ALS.EQ.ALPHA
836 ISAME( 6 ) = LZE( AS, AA, LAA )
837 ISAME( 7 ) = LDAS.EQ.LDA
838 ISAME( 8 ) = LZE( BS, BB, LBB )
839 ISAME( 9 ) = LDBS.EQ.LDB
840 ISAME( 10 ) = BLS.EQ.BETA
841 IF( NULL )THEN
842 ISAME( 11 ) = LZE( CS, CC, LCC )
843 ELSE
844 ISAME( 11 ) = LZERES( 'GE', ' ', M, N, CS,
845 $ CC, LDC )
846 END IF
847 ISAME( 12 ) = LDCS.EQ.LDC
848 *
849 * If data was incorrectly changed, report and
850 * return.
851 *
852 SAME = .TRUE.
853 DO 40 I = 1, NARGS
854 SAME = SAME.AND.ISAME( I )
855 IF( .NOT.ISAME( I ) )
856 $ WRITE( NOUT, FMT = 9998 )I
857 40 CONTINUE
858 IF( .NOT.SAME )THEN
859 FATAL = .TRUE.
860 GO TO 110
861 END IF
862 *
863 IF( .NOT.NULL )THEN
864 *
865 * Check the result.
866 *
867 IF( LEFT )THEN
868 CALL ZMMCH( 'N', 'N', M, N, M, ALPHA, A,
869 $ NMAX, B, NMAX, BETA, C, NMAX,
870 $ CT, G, CC, LDC, EPS, ERR,
871 $ FATAL, NOUT, .TRUE. )
872 ELSE
873 CALL ZMMCH( 'N', 'N', M, N, N, ALPHA, B,
874 $ NMAX, A, NMAX, BETA, C, NMAX,
875 $ CT, G, CC, LDC, EPS, ERR,
876 $ FATAL, NOUT, .TRUE. )
877 END IF
878 ERRMAX = MAX( ERRMAX, ERR )
879 * If got really bad answer, report and
880 * return.
881 IF( FATAL )
882 $ GO TO 110
883 END IF
884 *
885 50 CONTINUE
886 *
887 60 CONTINUE
888 *
889 70 CONTINUE
890 *
891 80 CONTINUE
892 *
893 90 CONTINUE
894 *
895 100 CONTINUE
896 *
897 * Report result.
898 *
899 IF( ERRMAX.LT.THRESH )THEN
900 WRITE( NOUT, FMT = 9999 )SNAME, NC
901 ELSE
902 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
903 END IF
904 GO TO 120
905 *
906 110 CONTINUE
907 WRITE( NOUT, FMT = 9996 )SNAME
908 WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA,
909 $ LDB, BETA, LDC
910 *
911 120 CONTINUE
912 RETURN
913 *
914 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
915 $ 'S)' )
916 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
917 $ 'ANGED INCORRECTLY *******' )
918 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
919 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
920 $ ' - SUSPECT *******' )
921 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
922 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
923 $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
924 $ ',', F4.1, '), C,', I3, ') .' )
925 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
926 $ '******' )
927 *
928 * End of ZCHK2.
929 *
930 END
931 SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
932 $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS,
933 $ B, BB, BS, CT, G, C )
934 *
935 * Tests ZTRMM and ZTRSM.
936 *
937 * Auxiliary routine for test program for Level 3 Blas.
938 *
939 * -- Written on 8-February-1989.
940 * Jack Dongarra, Argonne National Laboratory.
941 * Iain Duff, AERE Harwell.
942 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
943 * Sven Hammarling, Numerical Algorithms Group Ltd.
944 *
945 * .. Parameters ..
946 COMPLEX*16 ZERO, ONE
947 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ),
948 $ ONE = ( 1.0D0, 0.0D0 ) )
949 DOUBLE PRECISION RZERO
950 PARAMETER ( RZERO = 0.0D0 )
951 * .. Scalar Arguments ..
952 DOUBLE PRECISION EPS, THRESH
953 INTEGER NALF, NIDIM, NMAX, NOUT, NTRA
954 LOGICAL FATAL, REWI, TRACE
955 CHARACTER*6 SNAME
956 * .. Array Arguments ..
957 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
958 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
959 $ BB( NMAX*NMAX ), BS( NMAX*NMAX ),
960 $ C( NMAX, NMAX ), CT( NMAX )
961 DOUBLE PRECISION G( NMAX )
962 INTEGER IDIM( NIDIM )
963 * .. Local Scalars ..
964 COMPLEX*16 ALPHA, ALS
965 DOUBLE PRECISION ERR, ERRMAX
966 INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
967 $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
968 $ NS
969 LOGICAL LEFT, NULL, RESET, SAME
970 CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
971 $ UPLOS
972 CHARACTER*2 ICHD, ICHS, ICHU
973 CHARACTER*3 ICHT
974 * .. Local Arrays ..
975 LOGICAL ISAME( 13 )
976 * .. External Functions ..
977 LOGICAL LZE, LZERES
978 EXTERNAL LZE, LZERES
979 * .. External Subroutines ..
980 EXTERNAL ZMAKE, ZMMCH, ZTRMM, ZTRSM
981 * .. Intrinsic Functions ..
982 INTRINSIC MAX
983 * .. Scalars in Common ..
984 INTEGER INFOT, NOUTC
985 LOGICAL LERR, OK
986 * .. Common blocks ..
987 COMMON /INFOC/INFOT, NOUTC, OK, LERR
988 * .. Data statements ..
989 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/
990 * .. Executable Statements ..
991 *
992 NARGS = 11
993 NC = 0
994 RESET = .TRUE.
995 ERRMAX = RZERO
996 * Set up zero matrix for ZMMCH.
997 DO 20 J = 1, NMAX
998 DO 10 I = 1, NMAX
999 C( I, J ) = ZERO
1000 10 CONTINUE
1001 20 CONTINUE
1002 *
1003 DO 140 IM = 1, NIDIM
1004 M = IDIM( IM )
1005 *
1006 DO 130 IN = 1, NIDIM
1007 N = IDIM( IN )
1008 * Set LDB to 1 more than minimum value if room.
1009 LDB = M
1010 IF( LDB.LT.NMAX )
1011 $ LDB = LDB + 1
1012 * Skip tests if not enough room.
1013 IF( LDB.GT.NMAX )
1014 $ GO TO 130
1015 LBB = LDB*N
1016 NULL = M.LE.0.OR.N.LE.0
1017 *
1018 DO 120 ICS = 1, 2
1019 SIDE = ICHS( ICS: ICS )
1020 LEFT = SIDE.EQ.'L'
1021 IF( LEFT )THEN
1022 NA = M
1023 ELSE
1024 NA = N
1025 END IF
1026 * Set LDA to 1 more than minimum value if room.
1027 LDA = NA
1028 IF( LDA.LT.NMAX )
1029 $ LDA = LDA + 1
1030 * Skip tests if not enough room.
1031 IF( LDA.GT.NMAX )
1032 $ GO TO 130
1033 LAA = LDA*NA
1034 *
1035 DO 110 ICU = 1, 2
1036 UPLO = ICHU( ICU: ICU )
1037 *
1038 DO 100 ICT = 1, 3
1039 TRANSA = ICHT( ICT: ICT )
1040 *
1041 DO 90 ICD = 1, 2
1042 DIAG = ICHD( ICD: ICD )
1043 *
1044 DO 80 IA = 1, NALF
1045 ALPHA = ALF( IA )
1046 *
1047 * Generate the matrix A.
1048 *
1049 CALL ZMAKE( 'TR', UPLO, DIAG, NA, NA, A,
1050 $ NMAX, AA, LDA, RESET, ZERO )
1051 *
1052 * Generate the matrix B.
1053 *
1054 CALL ZMAKE( 'GE', ' ', ' ', M, N, B, NMAX,
1055 $ BB, LDB, RESET, ZERO )
1056 *
1057 NC = NC + 1
1058 *
1059 * Save every datum before calling the
1060 * subroutine.
1061 *
1062 SIDES = SIDE
1063 UPLOS = UPLO
1064 TRANAS = TRANSA
1065 DIAGS = DIAG
1066 MS = M
1067 NS = N
1068 ALS = ALPHA
1069 DO 30 I = 1, LAA
1070 AS( I ) = AA( I )
1071 30 CONTINUE
1072 LDAS = LDA
1073 DO 40 I = 1, LBB
1074 BS( I ) = BB( I )
1075 40 CONTINUE
1076 LDBS = LDB
1077 *
1078 * Call the subroutine.
1079 *
1080 IF( SNAME( 4: 5 ).EQ.'MM' )THEN
1081 IF( TRACE )
1082 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1083 $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1084 $ LDA, LDB
1085 IF( REWI )
1086 $ REWIND NTRA
1087 CALL ZTRMM( SIDE, UPLO, TRANSA, DIAG, M,
1088 $ N, ALPHA, AA, LDA, BB, LDB )
1089 ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
1090 IF( TRACE )
1091 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1092 $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1093 $ LDA, LDB
1094 IF( REWI )
1095 $ REWIND NTRA
1096 CALL ZTRSM( SIDE, UPLO, TRANSA, DIAG, M,
1097 $ N, ALPHA, AA, LDA, BB, LDB )
1098 END IF
1099 *
1100 * Check if error-exit was taken incorrectly.
1101 *
1102 IF( .NOT.OK )THEN
1103 WRITE( NOUT, FMT = 9994 )
1104 FATAL = .TRUE.
1105 GO TO 150
1106 END IF
1107 *
1108 * See what data changed inside subroutines.
1109 *
1110 ISAME( 1 ) = SIDES.EQ.SIDE
1111 ISAME( 2 ) = UPLOS.EQ.UPLO
1112 ISAME( 3 ) = TRANAS.EQ.TRANSA
1113 ISAME( 4 ) = DIAGS.EQ.DIAG
1114 ISAME( 5 ) = MS.EQ.M
1115 ISAME( 6 ) = NS.EQ.N
1116 ISAME( 7 ) = ALS.EQ.ALPHA
1117 ISAME( 8 ) = LZE( AS, AA, LAA )
1118 ISAME( 9 ) = LDAS.EQ.LDA
1119 IF( NULL )THEN
1120 ISAME( 10 ) = LZE( BS, BB, LBB )
1121 ELSE
1122 ISAME( 10 ) = LZERES( 'GE', ' ', M, N, BS,
1123 $ BB, LDB )
1124 END IF
1125 ISAME( 11 ) = LDBS.EQ.LDB
1126 *
1127 * If data was incorrectly changed, report and
1128 * return.
1129 *
1130 SAME = .TRUE.
1131 DO 50 I = 1, NARGS
1132 SAME = SAME.AND.ISAME( I )
1133 IF( .NOT.ISAME( I ) )
1134 $ WRITE( NOUT, FMT = 9998 )I
1135 50 CONTINUE
1136 IF( .NOT.SAME )THEN
1137 FATAL = .TRUE.
1138 GO TO 150
1139 END IF
1140 *
1141 IF( .NOT.NULL )THEN
1142 IF( SNAME( 4: 5 ).EQ.'MM' )THEN
1143 *
1144 * Check the result.
1145 *
1146 IF( LEFT )THEN
1147 CALL ZMMCH( TRANSA, 'N', M, N, M,
1148 $ ALPHA, A, NMAX, B, NMAX,
1149 $ ZERO, C, NMAX, CT, G,
1150 $ BB, LDB, EPS, ERR,
1151 $ FATAL, NOUT, .TRUE. )
1152 ELSE
1153 CALL ZMMCH( 'N', TRANSA, M, N, N,
1154 $ ALPHA, B, NMAX, A, NMAX,
1155 $ ZERO, C, NMAX, CT, G,
1156 $ BB, LDB, EPS, ERR,
1157 $ FATAL, NOUT, .TRUE. )
1158 END IF
1159 ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
1160 *
1161 * Compute approximation to original
1162 * matrix.
1163 *
1164 DO 70 J = 1, N
1165 DO 60 I = 1, M
1166 C( I, J ) = BB( I + ( J - 1 )*
1167 $ LDB )
1168 BB( I + ( J - 1 )*LDB ) = ALPHA*
1169 $ B( I, J )
1170 60 CONTINUE
1171 70 CONTINUE
1172 *
1173 IF( LEFT )THEN
1174 CALL ZMMCH( TRANSA, 'N', M, N, M,
1175 $ ONE, A, NMAX, C, NMAX,
1176 $ ZERO, B, NMAX, CT, G,
1177 $ BB, LDB, EPS, ERR,
1178 $ FATAL, NOUT, .FALSE. )
1179 ELSE
1180 CALL ZMMCH( 'N', TRANSA, M, N, N,
1181 $ ONE, C, NMAX, A, NMAX,
1182 $ ZERO, B, NMAX, CT, G,
1183 $ BB, LDB, EPS, ERR,
1184 $ FATAL, NOUT, .FALSE. )
1185 END IF
1186 END IF
1187 ERRMAX = MAX( ERRMAX, ERR )
1188 * If got really bad answer, report and
1189 * return.
1190 IF( FATAL )
1191 $ GO TO 150
1192 END IF
1193 *
1194 80 CONTINUE
1195 *
1196 90 CONTINUE
1197 *
1198 100 CONTINUE
1199 *
1200 110 CONTINUE
1201 *
1202 120 CONTINUE
1203 *
1204 130 CONTINUE
1205 *
1206 140 CONTINUE
1207 *
1208 * Report result.
1209 *
1210 IF( ERRMAX.LT.THRESH )THEN
1211 WRITE( NOUT, FMT = 9999 )SNAME, NC
1212 ELSE
1213 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1214 END IF
1215 GO TO 160
1216 *
1217 150 CONTINUE
1218 WRITE( NOUT, FMT = 9996 )SNAME
1219 WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M,
1220 $ N, ALPHA, LDA, LDB
1221 *
1222 160 CONTINUE
1223 RETURN
1224 *
1225 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1226 $ 'S)' )
1227 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1228 $ 'ANGED INCORRECTLY *******' )
1229 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1230 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1231 $ ' - SUSPECT *******' )
1232 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1233 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ),
1234 $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ',
1235 $ ' .' )
1236 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1237 $ '******' )
1238 *
1239 * End of ZCHK3.
1240 *
1241 END
1242 SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1243 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1244 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
1245 *
1246 * Tests ZHERK and ZSYRK.
1247 *
1248 * Auxiliary routine for test program for Level 3 Blas.
1249 *
1250 * -- Written on 8-February-1989.
1251 * Jack Dongarra, Argonne National Laboratory.
1252 * Iain Duff, AERE Harwell.
1253 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1254 * Sven Hammarling, Numerical Algorithms Group Ltd.
1255 *
1256 * .. Parameters ..
1257 COMPLEX*16 ZERO
1258 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) )
1259 DOUBLE PRECISION RONE, RZERO
1260 PARAMETER ( RONE = 1.0D0, RZERO = 0.0D0 )
1261 * .. Scalar Arguments ..
1262 DOUBLE PRECISION EPS, THRESH
1263 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1264 LOGICAL FATAL, REWI, TRACE
1265 CHARACTER*6 SNAME
1266 * .. Array Arguments ..
1267 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1268 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1269 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
1270 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
1271 $ CS( NMAX*NMAX ), CT( NMAX )
1272 DOUBLE PRECISION G( NMAX )
1273 INTEGER IDIM( NIDIM )
1274 * .. Local Scalars ..
1275 COMPLEX*16 ALPHA, ALS, BETA, BETS
1276 DOUBLE PRECISION ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS
1277 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1278 $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1279 $ NARGS, NC, NS
1280 LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER
1281 CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS
1282 CHARACTER*2 ICHT, ICHU
1283 * .. Local Arrays ..
1284 LOGICAL ISAME( 13 )
1285 * .. External Functions ..
1286 LOGICAL LZE, LZERES
1287 EXTERNAL LZE, LZERES
1288 * .. External Subroutines ..
1289 EXTERNAL ZHERK, ZMAKE, ZMMCH, ZSYRK
1290 * .. Intrinsic Functions ..
1291 INTRINSIC DCMPLX, MAX, DBLE
1292 * .. Scalars in Common ..
1293 INTEGER INFOT, NOUTC
1294 LOGICAL LERR, OK
1295 * .. Common blocks ..
1296 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1297 * .. Data statements ..
1298 DATA ICHT/'NC'/, ICHU/'UL'/
1299 * .. Executable Statements ..
1300 CONJ = SNAME( 2: 3 ).EQ.'HE'
1301 *
1302 NARGS = 10
1303 NC = 0
1304 RESET = .TRUE.
1305 ERRMAX = RZERO
1306 *
1307 DO 100 IN = 1, NIDIM
1308 N = IDIM( IN )
1309 * Set LDC to 1 more than minimum value if room.
1310 LDC = N
1311 IF( LDC.LT.NMAX )
1312 $ LDC = LDC + 1
1313 * Skip tests if not enough room.
1314 IF( LDC.GT.NMAX )
1315 $ GO TO 100
1316 LCC = LDC*N
1317 *
1318 DO 90 IK = 1, NIDIM
1319 K = IDIM( IK )
1320 *
1321 DO 80 ICT = 1, 2
1322 TRANS = ICHT( ICT: ICT )
1323 TRAN = TRANS.EQ.'C'
1324 IF( TRAN.AND..NOT.CONJ )
1325 $ TRANS = 'T'
1326 IF( TRAN )THEN
1327 MA = K
1328 NA = N
1329 ELSE
1330 MA = N
1331 NA = K
1332 END IF
1333 * Set LDA to 1 more than minimum value if room.
1334 LDA = MA
1335 IF( LDA.LT.NMAX )
1336 $ LDA = LDA + 1
1337 * Skip tests if not enough room.
1338 IF( LDA.GT.NMAX )
1339 $ GO TO 80
1340 LAA = LDA*NA
1341 *
1342 * Generate the matrix A.
1343 *
1344 CALL ZMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
1345 $ RESET, ZERO )
1346 *
1347 DO 70 ICU = 1, 2
1348 UPLO = ICHU( ICU: ICU )
1349 UPPER = UPLO.EQ.'U'
1350 *
1351 DO 60 IA = 1, NALF
1352 ALPHA = ALF( IA )
1353 IF( CONJ )THEN
1354 RALPHA = DBLE( ALPHA )
1355 ALPHA = DCMPLX( RALPHA, RZERO )
1356 END IF
1357 *
1358 DO 50 IB = 1, NBET
1359 BETA = BET( IB )
1360 IF( CONJ )THEN
1361 RBETA = DBLE( BETA )
1362 BETA = DCMPLX( RBETA, RZERO )
1363 END IF
1364 NULL = N.LE.0
1365 IF( CONJ )
1366 $ NULL = NULL.OR.( ( K.LE.0.OR.RALPHA.EQ.
1367 $ RZERO ).AND.RBETA.EQ.RONE )
1368 *
1369 * Generate the matrix C.
1370 *
1371 CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C,
1372 $ NMAX, CC, LDC, RESET, ZERO )
1373 *
1374 NC = NC + 1
1375 *
1376 * Save every datum before calling the subroutine.
1377 *
1378 UPLOS = UPLO
1379 TRANSS = TRANS
1380 NS = N
1381 KS = K
1382 IF( CONJ )THEN
1383 RALS = RALPHA
1384 ELSE
1385 ALS = ALPHA
1386 END IF
1387 DO 10 I = 1, LAA
1388 AS( I ) = AA( I )
1389 10 CONTINUE
1390 LDAS = LDA
1391 IF( CONJ )THEN
1392 RBETS = RBETA
1393 ELSE
1394 BETS = BETA
1395 END IF
1396 DO 20 I = 1, LCC
1397 CS( I ) = CC( I )
1398 20 CONTINUE
1399 LDCS = LDC
1400 *
1401 * Call the subroutine.
1402 *
1403 IF( CONJ )THEN
1404 IF( TRACE )
1405 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
1406 $ TRANS, N, K, RALPHA, LDA, RBETA, LDC
1407 IF( REWI )
1408 $ REWIND NTRA
1409 CALL ZHERK( UPLO, TRANS, N, K, RALPHA, AA,
1410 $ LDA, RBETA, CC, LDC )
1411 ELSE
1412 IF( TRACE )
1413 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO,
1414 $ TRANS, N, K, ALPHA, LDA, BETA, LDC
1415 IF( REWI )
1416 $ REWIND NTRA
1417 CALL ZSYRK( UPLO, TRANS, N, K, ALPHA, AA,
1418 $ LDA, BETA, CC, LDC )
1419 END IF
1420 *
1421 * Check if error-exit was taken incorrectly.
1422 *
1423 IF( .NOT.OK )THEN
1424 WRITE( NOUT, FMT = 9992 )
1425 FATAL = .TRUE.
1426 GO TO 120
1427 END IF
1428 *
1429 * See what data changed inside subroutines.
1430 *
1431 ISAME( 1 ) = UPLOS.EQ.UPLO
1432 ISAME( 2 ) = TRANSS.EQ.TRANS
1433 ISAME( 3 ) = NS.EQ.N
1434 ISAME( 4 ) = KS.EQ.K
1435 IF( CONJ )THEN
1436 ISAME( 5 ) = RALS.EQ.RALPHA
1437 ELSE
1438 ISAME( 5 ) = ALS.EQ.ALPHA
1439 END IF
1440 ISAME( 6 ) = LZE( AS, AA, LAA )
1441 ISAME( 7 ) = LDAS.EQ.LDA
1442 IF( CONJ )THEN
1443 ISAME( 8 ) = RBETS.EQ.RBETA
1444 ELSE
1445 ISAME( 8 ) = BETS.EQ.BETA
1446 END IF
1447 IF( NULL )THEN
1448 ISAME( 9 ) = LZE( CS, CC, LCC )
1449 ELSE
1450 ISAME( 9 ) = LZERES( SNAME( 2: 3 ), UPLO, N,
1451 $ N, CS, CC, LDC )
1452 END IF
1453 ISAME( 10 ) = LDCS.EQ.LDC
1454 *
1455 * If data was incorrectly changed, report and
1456 * return.
1457 *
1458 SAME = .TRUE.
1459 DO 30 I = 1, NARGS
1460 SAME = SAME.AND.ISAME( I )
1461 IF( .NOT.ISAME( I ) )
1462 $ WRITE( NOUT, FMT = 9998 )I
1463 30 CONTINUE
1464 IF( .NOT.SAME )THEN
1465 FATAL = .TRUE.
1466 GO TO 120
1467 END IF
1468 *
1469 IF( .NOT.NULL )THEN
1470 *
1471 * Check the result column by column.
1472 *
1473 IF( CONJ )THEN
1474 TRANST = 'C'
1475 ELSE
1476 TRANST = 'T'
1477 END IF
1478 JC = 1
1479 DO 40 J = 1, N
1480 IF( UPPER )THEN
1481 JJ = 1
1482 LJ = J
1483 ELSE
1484 JJ = J
1485 LJ = N - J + 1
1486 END IF
1487 IF( TRAN )THEN
1488 CALL ZMMCH( TRANST, 'N', LJ, 1, K,
1489 $ ALPHA, A( 1, JJ ), NMAX,
1490 $ A( 1, J ), NMAX, BETA,
1491 $ C( JJ, J ), NMAX, CT, G,
1492 $ CC( JC ), LDC, EPS, ERR,
1493 $ FATAL, NOUT, .TRUE. )
1494 ELSE
1495 CALL ZMMCH( 'N', TRANST, LJ, 1, K,
1496 $ ALPHA, A( JJ, 1 ), NMAX,
1497 $ A( J, 1 ), NMAX, BETA,
1498 $ C( JJ, J ), NMAX, CT, G,
1499 $ CC( JC ), LDC, EPS, ERR,
1500 $ FATAL, NOUT, .TRUE. )
1501 END IF
1502 IF( UPPER )THEN
1503 JC = JC + LDC
1504 ELSE
1505 JC = JC + LDC + 1
1506 END IF
1507 ERRMAX = MAX( ERRMAX, ERR )
1508 * If got really bad answer, report and
1509 * return.
1510 IF( FATAL )
1511 $ GO TO 110
1512 40 CONTINUE
1513 END IF
1514 *
1515 50 CONTINUE
1516 *
1517 60 CONTINUE
1518 *
1519 70 CONTINUE
1520 *
1521 80 CONTINUE
1522 *
1523 90 CONTINUE
1524 *
1525 100 CONTINUE
1526 *
1527 * Report result.
1528 *
1529 IF( ERRMAX.LT.THRESH )THEN
1530 WRITE( NOUT, FMT = 9999 )SNAME, NC
1531 ELSE
1532 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1533 END IF
1534 GO TO 130
1535 *
1536 110 CONTINUE
1537 IF( N.GT.1 )
1538 $ WRITE( NOUT, FMT = 9995 )J
1539 *
1540 120 CONTINUE
1541 WRITE( NOUT, FMT = 9996 )SNAME
1542 IF( CONJ )THEN
1543 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, RALPHA,
1544 $ LDA, RBETA, LDC
1545 ELSE
1546 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
1547 $ LDA, BETA, LDC
1548 END IF
1549 *
1550 130 CONTINUE
1551 RETURN
1552 *
1553 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1554 $ 'S)' )
1555 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1556 $ 'ANGED INCORRECTLY *******' )
1557 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1558 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1559 $ ' - SUSPECT *******' )
1560 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1561 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1562 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1563 $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ',
1564 $ ' .' )
1565 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1566 $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1,
1567 $ '), C,', I3, ') .' )
1568 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1569 $ '******' )
1570 *
1571 * End of ZCHK4.
1572 *
1573 END
1574 SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1575 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1576 $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
1577 *
1578 * Tests ZHER2K and ZSYR2K.
1579 *
1580 * Auxiliary routine for test program for Level 3 Blas.
1581 *
1582 * -- Written on 8-February-1989.
1583 * Jack Dongarra, Argonne National Laboratory.
1584 * Iain Duff, AERE Harwell.
1585 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1586 * Sven Hammarling, Numerical Algorithms Group Ltd.
1587 *
1588 * .. Parameters ..
1589 COMPLEX*16 ZERO, ONE
1590 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ),
1591 $ ONE = ( 1.0D0, 0.0D0 ) )
1592 DOUBLE PRECISION RONE, RZERO
1593 PARAMETER ( RONE = 1.0D0, RZERO = 0.0D0 )
1594 * .. Scalar Arguments ..
1595 DOUBLE PRECISION EPS, THRESH
1596 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1597 LOGICAL FATAL, REWI, TRACE
1598 CHARACTER*6 SNAME
1599 * .. Array Arguments ..
1600 COMPLEX*16 AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1601 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1602 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1603 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1604 $ W( 2*NMAX )
1605 DOUBLE PRECISION G( NMAX )
1606 INTEGER IDIM( NIDIM )
1607 * .. Local Scalars ..
1608 COMPLEX*16 ALPHA, ALS, BETA, BETS
1609 DOUBLE PRECISION ERR, ERRMAX, RBETA, RBETS
1610 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1611 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1612 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1613 LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER
1614 CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS
1615 CHARACTER*2 ICHT, ICHU
1616 * .. Local Arrays ..
1617 LOGICAL ISAME( 13 )
1618 * .. External Functions ..
1619 LOGICAL LZE, LZERES
1620 EXTERNAL LZE, LZERES
1621 * .. External Subroutines ..
1622 EXTERNAL ZHER2K, ZMAKE, ZMMCH, ZSYR2K
1623 * .. Intrinsic Functions ..
1624 INTRINSIC DCMPLX, DCONJG, MAX, DBLE
1625 * .. Scalars in Common ..
1626 INTEGER INFOT, NOUTC
1627 LOGICAL LERR, OK
1628 * .. Common blocks ..
1629 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1630 * .. Data statements ..
1631 DATA ICHT/'NC'/, ICHU/'UL'/
1632 * .. Executable Statements ..
1633 CONJ = SNAME( 2: 3 ).EQ.'HE'
1634 *
1635 NARGS = 12
1636 NC = 0
1637 RESET = .TRUE.
1638 ERRMAX = RZERO
1639 *
1640 DO 130 IN = 1, NIDIM
1641 N = IDIM( IN )
1642 * Set LDC to 1 more than minimum value if room.
1643 LDC = N
1644 IF( LDC.LT.NMAX )
1645 $ LDC = LDC + 1
1646 * Skip tests if not enough room.
1647 IF( LDC.GT.NMAX )
1648 $ GO TO 130
1649 LCC = LDC*N
1650 *
1651 DO 120 IK = 1, NIDIM
1652 K = IDIM( IK )
1653 *
1654 DO 110 ICT = 1, 2
1655 TRANS = ICHT( ICT: ICT )
1656 TRAN = TRANS.EQ.'C'
1657 IF( TRAN.AND..NOT.CONJ )
1658 $ TRANS = 'T'
1659 IF( TRAN )THEN
1660 MA = K
1661 NA = N
1662 ELSE
1663 MA = N
1664 NA = K
1665 END IF
1666 * Set LDA to 1 more than minimum value if room.
1667 LDA = MA
1668 IF( LDA.LT.NMAX )
1669 $ LDA = LDA + 1
1670 * Skip tests if not enough room.
1671 IF( LDA.GT.NMAX )
1672 $ GO TO 110
1673 LAA = LDA*NA
1674 *
1675 * Generate the matrix A.
1676 *
1677 IF( TRAN )THEN
1678 CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA,
1679 $ LDA, RESET, ZERO )
1680 ELSE
1681 CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA,
1682 $ RESET, ZERO )
1683 END IF
1684 *
1685 * Generate the matrix B.
1686 *
1687 LDB = LDA
1688 LBB = LAA
1689 IF( TRAN )THEN
1690 CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ),
1691 $ 2*NMAX, BB, LDB, RESET, ZERO )
1692 ELSE
1693 CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ),
1694 $ NMAX, BB, LDB, RESET, ZERO )
1695 END IF
1696 *
1697 DO 100 ICU = 1, 2
1698 UPLO = ICHU( ICU: ICU )
1699 UPPER = UPLO.EQ.'U'
1700 *
1701 DO 90 IA = 1, NALF
1702 ALPHA = ALF( IA )
1703 *
1704 DO 80 IB = 1, NBET
1705 BETA = BET( IB )
1706 IF( CONJ )THEN
1707 RBETA = DBLE( BETA )
1708 BETA = DCMPLX( RBETA, RZERO )
1709 END IF
1710 NULL = N.LE.0
1711 IF( CONJ )
1712 $ NULL = NULL.OR.( ( K.LE.0.OR.ALPHA.EQ.
1713 $ ZERO ).AND.RBETA.EQ.RONE )
1714 *
1715 * Generate the matrix C.
1716 *
1717 CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C,
1718 $ NMAX, CC, LDC, RESET, ZERO )
1719 *
1720 NC = NC + 1
1721 *
1722 * Save every datum before calling the subroutine.
1723 *
1724 UPLOS = UPLO
1725 TRANSS = TRANS
1726 NS = N
1727 KS = K
1728 ALS = ALPHA
1729 DO 10 I = 1, LAA
1730 AS( I ) = AA( I )
1731 10 CONTINUE
1732 LDAS = LDA
1733 DO 20 I = 1, LBB
1734 BS( I ) = BB( I )
1735 20 CONTINUE
1736 LDBS = LDB
1737 IF( CONJ )THEN
1738 RBETS = RBETA
1739 ELSE
1740 BETS = BETA
1741 END IF
1742 DO 30 I = 1, LCC
1743 CS( I ) = CC( I )
1744 30 CONTINUE
1745 LDCS = LDC
1746 *
1747 * Call the subroutine.
1748 *
1749 IF( CONJ )THEN
1750 IF( TRACE )
1751 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
1752 $ TRANS, N, K, ALPHA, LDA, LDB, RBETA, LDC
1753 IF( REWI )
1754 $ REWIND NTRA
1755 CALL ZHER2K( UPLO, TRANS, N, K, ALPHA, AA,
1756 $ LDA, BB, LDB, RBETA, CC, LDC )
1757 ELSE
1758 IF( TRACE )
1759 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO,
1760 $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC
1761 IF( REWI )
1762 $ REWIND NTRA
1763 CALL ZSYR2K( UPLO, TRANS, N, K, ALPHA, AA,
1764 $ LDA, BB, LDB, BETA, CC, LDC )
1765 END IF
1766 *
1767 * Check if error-exit was taken incorrectly.
1768 *
1769 IF( .NOT.OK )THEN
1770 WRITE( NOUT, FMT = 9992 )
1771 FATAL = .TRUE.
1772 GO TO 150
1773 END IF
1774 *
1775 * See what data changed inside subroutines.
1776 *
1777 ISAME( 1 ) = UPLOS.EQ.UPLO
1778 ISAME( 2 ) = TRANSS.EQ.TRANS
1779 ISAME( 3 ) = NS.EQ.N
1780 ISAME( 4 ) = KS.EQ.K
1781 ISAME( 5 ) = ALS.EQ.ALPHA
1782 ISAME( 6 ) = LZE( AS, AA, LAA )
1783 ISAME( 7 ) = LDAS.EQ.LDA
1784 ISAME( 8 ) = LZE( BS, BB, LBB )
1785 ISAME( 9 ) = LDBS.EQ.LDB
1786 IF( CONJ )THEN
1787 ISAME( 10 ) = RBETS.EQ.RBETA
1788 ELSE
1789 ISAME( 10 ) = BETS.EQ.BETA
1790 END IF
1791 IF( NULL )THEN
1792 ISAME( 11 ) = LZE( CS, CC, LCC )
1793 ELSE
1794 ISAME( 11 ) = LZERES( 'HE', UPLO, N, N, CS,
1795 $ CC, LDC )
1796 END IF
1797 ISAME( 12 ) = LDCS.EQ.LDC
1798 *
1799 * If data was incorrectly changed, report and
1800 * return.
1801 *
1802 SAME = .TRUE.
1803 DO 40 I = 1, NARGS
1804 SAME = SAME.AND.ISAME( I )
1805 IF( .NOT.ISAME( I ) )
1806 $ WRITE( NOUT, FMT = 9998 )I
1807 40 CONTINUE
1808 IF( .NOT.SAME )THEN
1809 FATAL = .TRUE.
1810 GO TO 150
1811 END IF
1812 *
1813 IF( .NOT.NULL )THEN
1814 *
1815 * Check the result column by column.
1816 *
1817 IF( CONJ )THEN
1818 TRANST = 'C'
1819 ELSE
1820 TRANST = 'T'
1821 END IF
1822 JJAB = 1
1823 JC = 1
1824 DO 70 J = 1, N
1825 IF( UPPER )THEN
1826 JJ = 1
1827 LJ = J
1828 ELSE
1829 JJ = J
1830 LJ = N - J + 1
1831 END IF
1832 IF( TRAN )THEN
1833 DO 50 I = 1, K
1834 W( I ) = ALPHA*AB( ( J - 1 )*2*
1835 $ NMAX + K + I )
1836 IF( CONJ )THEN
1837 W( K + I ) = DCONJG( ALPHA )*
1838 $ AB( ( J - 1 )*2*
1839 $ NMAX + I )
1840 ELSE
1841 W( K + I ) = ALPHA*
1842 $ AB( ( J - 1 )*2*
1843 $ NMAX + I )
1844 END IF
1845 50 CONTINUE
1846 CALL ZMMCH( TRANST, 'N', LJ, 1, 2*K,
1847 $ ONE, AB( JJAB ), 2*NMAX, W,
1848 $ 2*NMAX, BETA, C( JJ, J ),
1849 $ NMAX, CT, G, CC( JC ), LDC,
1850 $ EPS, ERR, FATAL, NOUT,
1851 $ .TRUE. )
1852 ELSE
1853 DO 60 I = 1, K
1854 IF( CONJ )THEN
1855 W( I ) = ALPHA*DCONJG( AB( ( K +
1856 $ I - 1 )*NMAX + J ) )
1857 W( K + I ) = DCONJG( ALPHA*
1858 $ AB( ( I - 1 )*NMAX +
1859 $ J ) )
1860 ELSE
1861 W( I ) = ALPHA*AB( ( K + I - 1 )*
1862 $ NMAX + J )
1863 W( K + I ) = ALPHA*
1864 $ AB( ( I - 1 )*NMAX +
1865 $ J )
1866 END IF
1867 60 CONTINUE
1868 CALL ZMMCH( 'N', 'N', LJ, 1, 2*K, ONE,
1869 $ AB( JJ ), NMAX, W, 2*NMAX,
1870 $ BETA, C( JJ, J ), NMAX, CT,
1871 $ G, CC( JC ), LDC, EPS, ERR,
1872 $ FATAL, NOUT, .TRUE. )
1873 END IF
1874 IF( UPPER )THEN
1875 JC = JC + LDC
1876 ELSE
1877 JC = JC + LDC + 1
1878 IF( TRAN )
1879 $ JJAB = JJAB + 2*NMAX
1880 END IF
1881 ERRMAX = MAX( ERRMAX, ERR )
1882 * If got really bad answer, report and
1883 * return.
1884 IF( FATAL )
1885 $ GO TO 140
1886 70 CONTINUE
1887 END IF
1888 *
1889 80 CONTINUE
1890 *
1891 90 CONTINUE
1892 *
1893 100 CONTINUE
1894 *
1895 110 CONTINUE
1896 *
1897 120 CONTINUE
1898 *
1899 130 CONTINUE
1900 *
1901 * Report result.
1902 *
1903 IF( ERRMAX.LT.THRESH )THEN
1904 WRITE( NOUT, FMT = 9999 )SNAME, NC
1905 ELSE
1906 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1907 END IF
1908 GO TO 160
1909 *
1910 140 CONTINUE
1911 IF( N.GT.1 )
1912 $ WRITE( NOUT, FMT = 9995 )J
1913 *
1914 150 CONTINUE
1915 WRITE( NOUT, FMT = 9996 )SNAME
1916 IF( CONJ )THEN
1917 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
1918 $ LDA, LDB, RBETA, LDC
1919 ELSE
1920 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
1921 $ LDA, LDB, BETA, LDC
1922 END IF
1923 *
1924 160 CONTINUE
1925 RETURN
1926 *
1927 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1928 $ 'S)' )
1929 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1930 $ 'ANGED INCORRECTLY *******' )
1931 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1932 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1933 $ ' - SUSPECT *******' )
1934 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1935 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1936 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1937 $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1,
1938 $ ', C,', I3, ') .' )
1939 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1940 $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
1941 $ ',', F4.1, '), C,', I3, ') .' )
1942 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1943 $ '******' )
1944 *
1945 * End of ZCHK5.
1946 *
1947 END
1948 SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT )
1949 *
1950 * Tests the error exits from the Level 3 Blas.
1951 * Requires a special version of the error-handling routine XERBLA.
1952 * ALPHA, RALPHA, BETA, RBETA, A, B and C should not need to be defined.
1953 *
1954 * Auxiliary routine for test program for Level 3 Blas.
1955 *
1956 * -- Written on 8-February-1989.
1957 * Jack Dongarra, Argonne National Laboratory.
1958 * Iain Duff, AERE Harwell.
1959 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1960 * Sven Hammarling, Numerical Algorithms Group Ltd.
1961 *
1962 * .. Scalar Arguments ..
1963 INTEGER ISNUM, NOUT
1964 CHARACTER*6 SRNAMT
1965 * .. Scalars in Common ..
1966 INTEGER INFOT, NOUTC
1967 LOGICAL LERR, OK
1968 * .. Local Scalars ..
1969 COMPLEX*16 ALPHA, BETA
1970 DOUBLE PRECISION RALPHA, RBETA
1971 * .. Local Arrays ..
1972 COMPLEX*16 A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
1973 * .. External Subroutines ..
1974 EXTERNAL ZGEMM, ZHEMM, ZHER2K, ZHERK, CHKXER, ZSYMM,
1975 $ ZSYR2K, ZSYRK, ZTRMM, ZTRSM
1976 * .. Common blocks ..
1977 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1978 * .. Executable Statements ..
1979 * OK is set to .FALSE. by the special version of XERBLA or by CHKXER
1980 * if anything is wrong.
1981 OK = .TRUE.
1982 * LERR is set to .TRUE. by the special version of XERBLA each time
1983 * it is called, and is then tested and re-set by CHKXER.
1984 LERR = .FALSE.
1985 GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
1986 $ 90 )ISNUM
1987 10 INFOT = 1
1988 CALL ZGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1989 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1990 INFOT = 1
1991 CALL ZGEMM( '/', 'C', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1992 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1993 INFOT = 1
1994 CALL ZGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1995 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1996 INFOT = 2
1997 CALL ZGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1998 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1999 INFOT = 2
2000 CALL ZGEMM( 'C', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2001 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2002 INFOT = 2
2003 CALL ZGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2004 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2005 INFOT = 3
2006 CALL ZGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2007 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2008 INFOT = 3
2009 CALL ZGEMM( 'N', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2010 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2011 INFOT = 3
2012 CALL ZGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2013 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2014 INFOT = 3
2015 CALL ZGEMM( 'C', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2016 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2017 INFOT = 3
2018 CALL ZGEMM( 'C', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2019 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2020 INFOT = 3
2021 CALL ZGEMM( 'C', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2022 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2023 INFOT = 3
2024 CALL ZGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2025 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2026 INFOT = 3
2027 CALL ZGEMM( 'T', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2028 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2029 INFOT = 3
2030 CALL ZGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2031 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2032 INFOT = 4
2033 CALL ZGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2034 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2035 INFOT = 4
2036 CALL ZGEMM( 'N', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2037 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2038 INFOT = 4
2039 CALL ZGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2040 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2041 INFOT = 4
2042 CALL ZGEMM( 'C', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2043 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2044 INFOT = 4
2045 CALL ZGEMM( 'C', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2046 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2047 INFOT = 4
2048 CALL ZGEMM( 'C', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2049 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2050 INFOT = 4
2051 CALL ZGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2052 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2053 INFOT = 4
2054 CALL ZGEMM( 'T', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2055 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2056 INFOT = 4
2057 CALL ZGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2058 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2059 INFOT = 5
2060 CALL ZGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2061 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2062 INFOT = 5
2063 CALL ZGEMM( 'N', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2064 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2065 INFOT = 5
2066 CALL ZGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2067 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2068 INFOT = 5
2069 CALL ZGEMM( 'C', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2070 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2071 INFOT = 5
2072 CALL ZGEMM( 'C', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2073 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2074 INFOT = 5
2075 CALL ZGEMM( 'C', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2076 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2077 INFOT = 5
2078 CALL ZGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2079 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2080 INFOT = 5
2081 CALL ZGEMM( 'T', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2082 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2083 INFOT = 5
2084 CALL ZGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2085 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2086 INFOT = 8
2087 CALL ZGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2088 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2089 INFOT = 8
2090 CALL ZGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2091 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2092 INFOT = 8
2093 CALL ZGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2094 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2095 INFOT = 8
2096 CALL ZGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
2097 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2098 INFOT = 8
2099 CALL ZGEMM( 'C', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2100 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2101 INFOT = 8
2102 CALL ZGEMM( 'C', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2103 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2104 INFOT = 8
2105 CALL ZGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
2106 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2107 INFOT = 8
2108 CALL ZGEMM( 'T', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2109 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2110 INFOT = 8
2111 CALL ZGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2112 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2113 INFOT = 10
2114 CALL ZGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2115 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2116 INFOT = 10
2117 CALL ZGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
2118 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2119 INFOT = 10
2120 CALL ZGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
2121 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2122 INFOT = 10
2123 CALL ZGEMM( 'N', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2124 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2125 INFOT = 10
2126 CALL ZGEMM( 'C', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2127 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2128 INFOT = 10
2129 CALL ZGEMM( 'T', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2130 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2131 INFOT = 10
2132 CALL ZGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2133 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2134 INFOT = 10
2135 CALL ZGEMM( 'C', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2136 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2137 INFOT = 10
2138 CALL ZGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2139 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2140 INFOT = 13
2141 CALL ZGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2142 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2143 INFOT = 13
2144 CALL ZGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2145 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2146 INFOT = 13
2147 CALL ZGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2148 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2149 INFOT = 13
2150 CALL ZGEMM( 'C', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2151 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2152 INFOT = 13
2153 CALL ZGEMM( 'C', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2154 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2155 INFOT = 13
2156 CALL ZGEMM( 'C', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2157 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2158 INFOT = 13
2159 CALL ZGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2160 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2161 INFOT = 13
2162 CALL ZGEMM( 'T', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2163 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2164 INFOT = 13
2165 CALL ZGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2166 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2167 GO TO 100
2168 20 INFOT = 1
2169 CALL ZHEMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2170 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2171 INFOT = 2
2172 CALL ZHEMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2173 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2174 INFOT = 3
2175 CALL ZHEMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2176 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2177 INFOT = 3
2178 CALL ZHEMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2179 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2180 INFOT = 3
2181 CALL ZHEMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2182 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2183 INFOT = 3
2184 CALL ZHEMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2185 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2186 INFOT = 4
2187 CALL ZHEMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2188 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2189 INFOT = 4
2190 CALL ZHEMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2191 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2192 INFOT = 4
2193 CALL ZHEMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2194 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2195 INFOT = 4
2196 CALL ZHEMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2197 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2198 INFOT = 7
2199 CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
2200 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2201 INFOT = 7
2202 CALL ZHEMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2203 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2204 INFOT = 7
2205 CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
2206 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2207 INFOT = 7
2208 CALL ZHEMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2209 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2210 INFOT = 9
2211 CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2212 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2213 INFOT = 9
2214 CALL ZHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2215 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2216 INFOT = 9
2217 CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2218 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2219 INFOT = 9
2220 CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2221 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2222 INFOT = 12
2223 CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2224 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2225 INFOT = 12
2226 CALL ZHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
2227 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2228 INFOT = 12
2229 CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2230 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2231 INFOT = 12
2232 CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
2233 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2234 GO TO 100
2235 30 INFOT = 1
2236 CALL ZSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2237 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2238 INFOT = 2
2239 CALL ZSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2240 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2241 INFOT = 3
2242 CALL ZSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2243 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2244 INFOT = 3
2245 CALL ZSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2246 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2247 INFOT = 3
2248 CALL ZSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2249 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2250 INFOT = 3
2251 CALL ZSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2252 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2253 INFOT = 4
2254 CALL ZSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2255 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2256 INFOT = 4
2257 CALL ZSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2258 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2259 INFOT = 4
2260 CALL ZSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2261 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2262 INFOT = 4
2263 CALL ZSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2264 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2265 INFOT = 7
2266 CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
2267 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2268 INFOT = 7
2269 CALL ZSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2270 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2271 INFOT = 7
2272 CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
2273 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2274 INFOT = 7
2275 CALL ZSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2276 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2277 INFOT = 9
2278 CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2279 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2280 INFOT = 9
2281 CALL ZSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2282 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2283 INFOT = 9
2284 CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2285 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2286 INFOT = 9
2287 CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2288 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2289 INFOT = 12
2290 CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2291 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2292 INFOT = 12
2293 CALL ZSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
2294 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2295 INFOT = 12
2296 CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2297 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2298 INFOT = 12
2299 CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
2300 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2301 GO TO 100
2302 40 INFOT = 1
2303 CALL ZTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2304 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2305 INFOT = 2
2306 CALL ZTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2307 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2308 INFOT = 3
2309 CALL ZTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2310 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2311 INFOT = 4
2312 CALL ZTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
2313 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2314 INFOT = 5
2315 CALL ZTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2316 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2317 INFOT = 5
2318 CALL ZTRMM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2319 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2320 INFOT = 5
2321 CALL ZTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2322 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2323 INFOT = 5
2324 CALL ZTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2325 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2326 INFOT = 5
2327 CALL ZTRMM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2328 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2329 INFOT = 5
2330 CALL ZTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2331 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2332 INFOT = 5
2333 CALL ZTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2334 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2335 INFOT = 5
2336 CALL ZTRMM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2337 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2338 INFOT = 5
2339 CALL ZTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2340 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2341 INFOT = 5
2342 CALL ZTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2343 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2344 INFOT = 5
2345 CALL ZTRMM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2346 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2347 INFOT = 5
2348 CALL ZTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2349 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2350 INFOT = 6
2351 CALL ZTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2352 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2353 INFOT = 6
2354 CALL ZTRMM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2355 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2356 INFOT = 6
2357 CALL ZTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2358 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2359 INFOT = 6
2360 CALL ZTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2361 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2362 INFOT = 6
2363 CALL ZTRMM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2364 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2365 INFOT = 6
2366 CALL ZTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2367 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2368 INFOT = 6
2369 CALL ZTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2370 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2371 INFOT = 6
2372 CALL ZTRMM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2373 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2374 INFOT = 6
2375 CALL ZTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2376 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2377 INFOT = 6
2378 CALL ZTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2379 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2380 INFOT = 6
2381 CALL ZTRMM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2382 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2383 INFOT = 6
2384 CALL ZTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2385 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2386 INFOT = 9
2387 CALL ZTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2388 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2389 INFOT = 9
2390 CALL ZTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2391 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2392 INFOT = 9
2393 CALL ZTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2394 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2395 INFOT = 9
2396 CALL ZTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2397 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2398 INFOT = 9
2399 CALL ZTRMM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2400 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2401 INFOT = 9
2402 CALL ZTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2403 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2404 INFOT = 9
2405 CALL ZTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2406 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2407 INFOT = 9
2408 CALL ZTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2409 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2410 INFOT = 9
2411 CALL ZTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2412 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2413 INFOT = 9
2414 CALL ZTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2415 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2416 INFOT = 9
2417 CALL ZTRMM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2418 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2419 INFOT = 9
2420 CALL ZTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2421 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2422 INFOT = 11
2423 CALL ZTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2424 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2425 INFOT = 11
2426 CALL ZTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2427 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2428 INFOT = 11
2429 CALL ZTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2430 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2431 INFOT = 11
2432 CALL ZTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2433 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2434 INFOT = 11
2435 CALL ZTRMM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2436 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2437 INFOT = 11
2438 CALL ZTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2439 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2440 INFOT = 11
2441 CALL ZTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2442 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2443 INFOT = 11
2444 CALL ZTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2445 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2446 INFOT = 11
2447 CALL ZTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2448 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2449 INFOT = 11
2450 CALL ZTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2451 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2452 INFOT = 11
2453 CALL ZTRMM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2454 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2455 INFOT = 11
2456 CALL ZTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2457 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2458 GO TO 100
2459 50 INFOT = 1
2460 CALL ZTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2461 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2462 INFOT = 2
2463 CALL ZTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2464 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2465 INFOT = 3
2466 CALL ZTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2467 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2468 INFOT = 4
2469 CALL ZTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
2470 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2471 INFOT = 5
2472 CALL ZTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2473 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2474 INFOT = 5
2475 CALL ZTRSM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2476 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2477 INFOT = 5
2478 CALL ZTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2479 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2480 INFOT = 5
2481 CALL ZTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2482 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2483 INFOT = 5
2484 CALL ZTRSM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2485 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2486 INFOT = 5
2487 CALL ZTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2488 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2489 INFOT = 5
2490 CALL ZTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2491 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2492 INFOT = 5
2493 CALL ZTRSM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2494 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2495 INFOT = 5
2496 CALL ZTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2497 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2498 INFOT = 5
2499 CALL ZTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2500 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2501 INFOT = 5
2502 CALL ZTRSM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2503 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2504 INFOT = 5
2505 CALL ZTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2506 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2507 INFOT = 6
2508 CALL ZTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2509 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2510 INFOT = 6
2511 CALL ZTRSM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2512 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2513 INFOT = 6
2514 CALL ZTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2515 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2516 INFOT = 6
2517 CALL ZTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2518 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2519 INFOT = 6
2520 CALL ZTRSM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2521 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2522 INFOT = 6
2523 CALL ZTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2524 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2525 INFOT = 6
2526 CALL ZTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2527 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2528 INFOT = 6
2529 CALL ZTRSM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2530 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2531 INFOT = 6
2532 CALL ZTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2533 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2534 INFOT = 6
2535 CALL ZTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2536 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2537 INFOT = 6
2538 CALL ZTRSM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2539 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2540 INFOT = 6
2541 CALL ZTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2542 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2543 INFOT = 9
2544 CALL ZTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2545 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2546 INFOT = 9
2547 CALL ZTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2548 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2549 INFOT = 9
2550 CALL ZTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2551 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2552 INFOT = 9
2553 CALL ZTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2554 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2555 INFOT = 9
2556 CALL ZTRSM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2557 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2558 INFOT = 9
2559 CALL ZTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2560 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2561 INFOT = 9
2562 CALL ZTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2563 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2564 INFOT = 9
2565 CALL ZTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2566 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2567 INFOT = 9
2568 CALL ZTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2569 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2570 INFOT = 9
2571 CALL ZTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2572 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2573 INFOT = 9
2574 CALL ZTRSM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2575 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2576 INFOT = 9
2577 CALL ZTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2578 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2579 INFOT = 11
2580 CALL ZTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2581 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2582 INFOT = 11
2583 CALL ZTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2584 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2585 INFOT = 11
2586 CALL ZTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2587 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2588 INFOT = 11
2589 CALL ZTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2590 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2591 INFOT = 11
2592 CALL ZTRSM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2593 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2594 INFOT = 11
2595 CALL ZTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2596 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2597 INFOT = 11
2598 CALL ZTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2599 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2600 INFOT = 11
2601 CALL ZTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2602 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2603 INFOT = 11
2604 CALL ZTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2605 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2606 INFOT = 11
2607 CALL ZTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2608 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2609 INFOT = 11
2610 CALL ZTRSM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2611 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2612 INFOT = 11
2613 CALL ZTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2614 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2615 GO TO 100
2616 60 INFOT = 1
2617 CALL ZHERK( '/', 'N', 0, 0, RALPHA, A, 1, RBETA, C, 1 )
2618 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2619 INFOT = 2
2620 CALL ZHERK( 'U', 'T', 0, 0, RALPHA, A, 1, RBETA, C, 1 )
2621 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2622 INFOT = 3
2623 CALL ZHERK( 'U', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 )
2624 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2625 INFOT = 3
2626 CALL ZHERK( 'U', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 )
2627 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2628 INFOT = 3
2629 CALL ZHERK( 'L', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 )
2630 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2631 INFOT = 3
2632 CALL ZHERK( 'L', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 )
2633 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2634 INFOT = 4
2635 CALL ZHERK( 'U', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 )
2636 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2637 INFOT = 4
2638 CALL ZHERK( 'U', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 )
2639 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2640 INFOT = 4
2641 CALL ZHERK( 'L', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 )
2642 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2643 INFOT = 4
2644 CALL ZHERK( 'L', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 )
2645 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2646 INFOT = 7
2647 CALL ZHERK( 'U', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 )
2648 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2649 INFOT = 7
2650 CALL ZHERK( 'U', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 )
2651 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2652 INFOT = 7
2653 CALL ZHERK( 'L', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 )
2654 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2655 INFOT = 7
2656 CALL ZHERK( 'L', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 )
2657 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2658 INFOT = 10
2659 CALL ZHERK( 'U', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 )
2660 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2661 INFOT = 10
2662 CALL ZHERK( 'U', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 )
2663 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2664 INFOT = 10
2665 CALL ZHERK( 'L', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 )
2666 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2667 INFOT = 10
2668 CALL ZHERK( 'L', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 )
2669 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2670 GO TO 100
2671 70 INFOT = 1
2672 CALL ZSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 )
2673 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2674 INFOT = 2
2675 CALL ZSYRK( 'U', 'C', 0, 0, ALPHA, A, 1, BETA, C, 1 )
2676 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2677 INFOT = 3
2678 CALL ZSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2679 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2680 INFOT = 3
2681 CALL ZSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2682 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2683 INFOT = 3
2684 CALL ZSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2685 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2686 INFOT = 3
2687 CALL ZSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2688 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2689 INFOT = 4
2690 CALL ZSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2691 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2692 INFOT = 4
2693 CALL ZSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2694 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2695 INFOT = 4
2696 CALL ZSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2697 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2698 INFOT = 4
2699 CALL ZSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2700 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2701 INFOT = 7
2702 CALL ZSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
2703 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2704 INFOT = 7
2705 CALL ZSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
2706 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2707 INFOT = 7
2708 CALL ZSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
2709 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2710 INFOT = 7
2711 CALL ZSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
2712 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2713 INFOT = 10
2714 CALL ZSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
2715 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2716 INFOT = 10
2717 CALL ZSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
2718 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2719 INFOT = 10
2720 CALL ZSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
2721 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2722 INFOT = 10
2723 CALL ZSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
2724 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2725 GO TO 100
2726 80 INFOT = 1
2727 CALL ZHER2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2728 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2729 INFOT = 2
2730 CALL ZHER2K( 'U', 'T', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2731 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2732 INFOT = 3
2733 CALL ZHER2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2734 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2735 INFOT = 3
2736 CALL ZHER2K( 'U', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2737 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2738 INFOT = 3
2739 CALL ZHER2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2740 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2741 INFOT = 3
2742 CALL ZHER2K( 'L', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2743 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2744 INFOT = 4
2745 CALL ZHER2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2746 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2747 INFOT = 4
2748 CALL ZHER2K( 'U', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2749 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2750 INFOT = 4
2751 CALL ZHER2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2752 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2753 INFOT = 4
2754 CALL ZHER2K( 'L', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2755 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2756 INFOT = 7
2757 CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 )
2758 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2759 INFOT = 7
2760 CALL ZHER2K( 'U', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2761 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2762 INFOT = 7
2763 CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 )
2764 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2765 INFOT = 7
2766 CALL ZHER2K( 'L', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2767 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2768 INFOT = 9
2769 CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 )
2770 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2771 INFOT = 9
2772 CALL ZHER2K( 'U', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 )
2773 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2774 INFOT = 9
2775 CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 )
2776 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2777 INFOT = 9
2778 CALL ZHER2K( 'L', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 )
2779 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2780 INFOT = 12
2781 CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 )
2782 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2783 INFOT = 12
2784 CALL ZHER2K( 'U', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2785 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2786 INFOT = 12
2787 CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 )
2788 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2789 INFOT = 12
2790 CALL ZHER2K( 'L', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2791 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2792 GO TO 100
2793 90 INFOT = 1
2794 CALL ZSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2795 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2796 INFOT = 2
2797 CALL ZSYR2K( 'U', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2798 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2799 INFOT = 3
2800 CALL ZSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2801 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2802 INFOT = 3
2803 CALL ZSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2804 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2805 INFOT = 3
2806 CALL ZSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2807 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2808 INFOT = 3
2809 CALL ZSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2810 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2811 INFOT = 4
2812 CALL ZSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2813 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2814 INFOT = 4
2815 CALL ZSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2816 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2817 INFOT = 4
2818 CALL ZSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2819 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2820 INFOT = 4
2821 CALL ZSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2822 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2823 INFOT = 7
2824 CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2825 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2826 INFOT = 7
2827 CALL ZSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2828 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2829 INFOT = 7
2830 CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2831 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2832 INFOT = 7
2833 CALL ZSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2834 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2835 INFOT = 9
2836 CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
2837 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2838 INFOT = 9
2839 CALL ZSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
2840 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2841 INFOT = 9
2842 CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
2843 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2844 INFOT = 9
2845 CALL ZSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
2846 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2847 INFOT = 12
2848 CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2849 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2850 INFOT = 12
2851 CALL ZSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2852 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2853 INFOT = 12
2854 CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2855 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2856 INFOT = 12
2857 CALL ZSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2858 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2859 *
2860 100 IF( OK )THEN
2861 WRITE( NOUT, FMT = 9999 )SRNAMT
2862 ELSE
2863 WRITE( NOUT, FMT = 9998 )SRNAMT
2864 END IF
2865 RETURN
2866 *
2867 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
2868 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
2869 $ '**' )
2870 *
2871 * End of ZCHKE.
2872 *
2873 END
2874 SUBROUTINE ZMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
2875 $ TRANSL )
2876 *
2877 * Generates values for an M by N matrix A.
2878 * Stores the values in the array AA in the data structure required
2879 * by the routine, with unwanted elements set to rogue value.
2880 *
2881 * TYPE is 'GE', 'HE', 'SY' or 'TR'.
2882 *
2883 * Auxiliary routine for test program for Level 3 Blas.
2884 *
2885 * -- Written on 8-February-1989.
2886 * Jack Dongarra, Argonne National Laboratory.
2887 * Iain Duff, AERE Harwell.
2888 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2889 * Sven Hammarling, Numerical Algorithms Group Ltd.
2890 *
2891 * .. Parameters ..
2892 COMPLEX*16 ZERO, ONE
2893 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ),
2894 $ ONE = ( 1.0D0, 0.0D0 ) )
2895 COMPLEX*16 ROGUE
2896 PARAMETER ( ROGUE = ( -1.0D10, 1.0D10 ) )
2897 DOUBLE PRECISION RZERO
2898 PARAMETER ( RZERO = 0.0D0 )
2899 DOUBLE PRECISION RROGUE
2900 PARAMETER ( RROGUE = -1.0D10 )
2901 * .. Scalar Arguments ..
2902 COMPLEX*16 TRANSL
2903 INTEGER LDA, M, N, NMAX
2904 LOGICAL RESET
2905 CHARACTER*1 DIAG, UPLO
2906 CHARACTER*2 TYPE
2907 * .. Array Arguments ..
2908 COMPLEX*16 A( NMAX, * ), AA( * )
2909 * .. Local Scalars ..
2910 INTEGER I, IBEG, IEND, J, JJ
2911 LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER
2912 * .. External Functions ..
2913 COMPLEX*16 ZBEG
2914 EXTERNAL ZBEG
2915 * .. Intrinsic Functions ..
2916 INTRINSIC DCMPLX, DCONJG, DBLE
2917 * .. Executable Statements ..
2918 GEN = TYPE.EQ.'GE'
2919 HER = TYPE.EQ.'HE'
2920 SYM = TYPE.EQ.'SY'
2921 TRI = TYPE.EQ.'TR'
2922 UPPER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'U'
2923 LOWER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'L'
2924 UNIT = TRI.AND.DIAG.EQ.'U'
2925 *
2926 * Generate data in array A.
2927 *
2928 DO 20 J = 1, N
2929 DO 10 I = 1, M
2930 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
2931 $ THEN
2932 A( I, J ) = ZBEG( RESET ) + TRANSL
2933 IF( I.NE.J )THEN
2934 * Set some elements to zero
2935 IF( N.GT.3.AND.J.EQ.N/2 )
2936 $ A( I, J ) = ZERO
2937 IF( HER )THEN
2938 A( J, I ) = DCONJG( A( I, J ) )
2939 ELSE IF( SYM )THEN
2940 A( J, I ) = A( I, J )
2941 ELSE IF( TRI )THEN
2942 A( J, I ) = ZERO
2943 END IF
2944 END IF
2945 END IF
2946 10 CONTINUE
2947 IF( HER )
2948 $ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), RZERO )
2949 IF( TRI )
2950 $ A( J, J ) = A( J, J ) + ONE
2951 IF( UNIT )
2952 $ A( J, J ) = ONE
2953 20 CONTINUE
2954 *
2955 * Store elements in array AS in data structure required by routine.
2956 *
2957 IF( TYPE.EQ.'GE' )THEN
2958 DO 50 J = 1, N
2959 DO 30 I = 1, M
2960 AA( I + ( J - 1 )*LDA ) = A( I, J )
2961 30 CONTINUE
2962 DO 40 I = M + 1, LDA
2963 AA( I + ( J - 1 )*LDA ) = ROGUE
2964 40 CONTINUE
2965 50 CONTINUE
2966 ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
2967 DO 90 J = 1, N
2968 IF( UPPER )THEN
2969 IBEG = 1
2970 IF( UNIT )THEN
2971 IEND = J - 1
2972 ELSE
2973 IEND = J
2974 END IF
2975 ELSE
2976 IF( UNIT )THEN
2977 IBEG = J + 1
2978 ELSE
2979 IBEG = J
2980 END IF
2981 IEND = N
2982 END IF
2983 DO 60 I = 1, IBEG - 1
2984 AA( I + ( J - 1 )*LDA ) = ROGUE
2985 60 CONTINUE
2986 DO 70 I = IBEG, IEND
2987 AA( I + ( J - 1 )*LDA ) = A( I, J )
2988 70 CONTINUE
2989 DO 80 I = IEND + 1, LDA
2990 AA( I + ( J - 1 )*LDA ) = ROGUE
2991 80 CONTINUE
2992 IF( HER )THEN
2993 JJ = J + ( J - 1 )*LDA
2994 AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE )
2995 END IF
2996 90 CONTINUE
2997 END IF
2998 RETURN
2999 *
3000 * End of ZMAKE.
3001 *
3002 END
3003 SUBROUTINE ZMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
3004 $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
3005 $ NOUT, MV )
3006 *
3007 * Checks the results of the computational tests.
3008 *
3009 * Auxiliary routine for test program for Level 3 Blas.
3010 *
3011 * -- Written on 8-February-1989.
3012 * Jack Dongarra, Argonne National Laboratory.
3013 * Iain Duff, AERE Harwell.
3014 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3015 * Sven Hammarling, Numerical Algorithms Group Ltd.
3016 *
3017 * .. Parameters ..
3018 COMPLEX*16 ZERO
3019 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) )
3020 DOUBLE PRECISION RZERO, RONE
3021 PARAMETER ( RZERO = 0.0D0, RONE = 1.0D0 )
3022 * .. Scalar Arguments ..
3023 COMPLEX*16 ALPHA, BETA
3024 DOUBLE PRECISION EPS, ERR
3025 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
3026 LOGICAL FATAL, MV
3027 CHARACTER*1 TRANSA, TRANSB
3028 * .. Array Arguments ..
3029 COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ),
3030 $ CC( LDCC, * ), CT( * )
3031 DOUBLE PRECISION G( * )
3032 * .. Local Scalars ..
3033 COMPLEX*16 CL
3034 DOUBLE PRECISION ERRI
3035 INTEGER I, J, K
3036 LOGICAL CTRANA, CTRANB, TRANA, TRANB
3037 * .. Intrinsic Functions ..
3038 INTRINSIC ABS, DIMAG, DCONJG, MAX, DBLE, SQRT
3039 * .. Statement Functions ..
3040 DOUBLE PRECISION ABS1
3041 * .. Statement Function definitions ..
3042 ABS1( CL ) = ABS( DBLE( CL ) ) + ABS( DIMAG( CL ) )
3043 * .. Executable Statements ..
3044 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
3045 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
3046 CTRANA = TRANSA.EQ.'C'
3047 CTRANB = TRANSB.EQ.'C'
3048 *
3049 * Compute expected result, one column at a time, in CT using data
3050 * in A, B and C.
3051 * Compute gauges in G.
3052 *
3053 DO 220 J = 1, N
3054 *
3055 DO 10 I = 1, M
3056 CT( I ) = ZERO
3057 G( I ) = RZERO
3058 10 CONTINUE
3059 IF( .NOT.TRANA.AND..NOT.TRANB )THEN
3060 DO 30 K = 1, KK
3061 DO 20 I = 1, M
3062 CT( I ) = CT( I ) + A( I, K )*B( K, J )
3063 G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) )
3064 20 CONTINUE
3065 30 CONTINUE
3066 ELSE IF( TRANA.AND..NOT.TRANB )THEN
3067 IF( CTRANA )THEN
3068 DO 50 K = 1, KK
3069 DO 40 I = 1, M
3070 CT( I ) = CT( I ) + DCONJG( A( K, I ) )*B( K, J )
3071 G( I ) = G( I ) + ABS1( A( K, I ) )*
3072 $ ABS1( B( K, J ) )
3073 40 CONTINUE
3074 50 CONTINUE
3075 ELSE
3076 DO 70 K = 1, KK
3077 DO 60 I = 1, M
3078 CT( I ) = CT( I ) + A( K, I )*B( K, J )
3079 G( I ) = G( I ) + ABS1( A( K, I ) )*
3080 $ ABS1( B( K, J ) )
3081 60 CONTINUE
3082 70 CONTINUE
3083 END IF
3084 ELSE IF( .NOT.TRANA.AND.TRANB )THEN
3085 IF( CTRANB )THEN
3086 DO 90 K = 1, KK
3087 DO 80 I = 1, M
3088 CT( I ) = CT( I ) + A( I, K )*DCONJG( B( J, K ) )
3089 G( I ) = G( I ) + ABS1( A( I, K ) )*
3090 $ ABS1( B( J, K ) )
3091 80 CONTINUE
3092 90 CONTINUE
3093 ELSE
3094 DO 110 K = 1, KK
3095 DO 100 I = 1, M
3096 CT( I ) = CT( I ) + A( I, K )*B( J, K )
3097 G( I ) = G( I ) + ABS1( A( I, K ) )*
3098 $ ABS1( B( J, K ) )
3099 100 CONTINUE
3100 110 CONTINUE
3101 END IF
3102 ELSE IF( TRANA.AND.TRANB )THEN
3103 IF( CTRANA )THEN
3104 IF( CTRANB )THEN
3105 DO 130 K = 1, KK
3106 DO 120 I = 1, M
3107 CT( I ) = CT( I ) + DCONJG( A( K, I ) )*
3108 $ DCONJG( B( J, K ) )
3109 G( I ) = G( I ) + ABS1( A( K, I ) )*
3110 $ ABS1( B( J, K ) )
3111 120 CONTINUE
3112 130 CONTINUE
3113 ELSE
3114 DO 150 K = 1, KK
3115 DO 140 I = 1, M
3116 CT( I ) = CT( I ) + DCONJG( A( K, I ) )*
3117 $ B( J, K )
3118 G( I ) = G( I ) + ABS1( A( K, I ) )*
3119 $ ABS1( B( J, K ) )
3120 140 CONTINUE
3121 150 CONTINUE
3122 END IF
3123 ELSE
3124 IF( CTRANB )THEN
3125 DO 170 K = 1, KK
3126 DO 160 I = 1, M
3127 CT( I ) = CT( I ) + A( K, I )*
3128 $ DCONJG( B( J, K ) )
3129 G( I ) = G( I ) + ABS1( A( K, I ) )*
3130 $ ABS1( B( J, K ) )
3131 160 CONTINUE
3132 170 CONTINUE
3133 ELSE
3134 DO 190 K = 1, KK
3135 DO 180 I = 1, M
3136 CT( I ) = CT( I ) + A( K, I )*B( J, K )
3137 G( I ) = G( I ) + ABS1( A( K, I ) )*
3138 $ ABS1( B( J, K ) )
3139 180 CONTINUE
3140 190 CONTINUE
3141 END IF
3142 END IF
3143 END IF
3144 DO 200 I = 1, M
3145 CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
3146 G( I ) = ABS1( ALPHA )*G( I ) +
3147 $ ABS1( BETA )*ABS1( C( I, J ) )
3148 200 CONTINUE
3149 *
3150 * Compute the error ratio for this result.
3151 *
3152 ERR = ZERO
3153 DO 210 I = 1, M
3154 ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS
3155 IF( G( I ).NE.RZERO )
3156 $ ERRI = ERRI/G( I )
3157 ERR = MAX( ERR, ERRI )
3158 IF( ERR*SQRT( EPS ).GE.RONE )
3159 $ GO TO 230
3160 210 CONTINUE
3161 *
3162 220 CONTINUE
3163 *
3164 * If the loop completes, all results are at least half accurate.
3165 GO TO 250
3166 *
3167 * Report fatal error.
3168 *
3169 230 FATAL = .TRUE.
3170 WRITE( NOUT, FMT = 9999 )
3171 DO 240 I = 1, M
3172 IF( MV )THEN
3173 WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
3174 ELSE
3175 WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
3176 END IF
3177 240 CONTINUE
3178 IF( N.GT.1 )
3179 $ WRITE( NOUT, FMT = 9997 )J
3180 *
3181 250 CONTINUE
3182 RETURN
3183 *
3184 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3185 $ 'F ACCURATE *******', /' EXPECTED RE',
3186 $ 'SULT COMPUTED RESULT' )
3187 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) )
3188 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
3189 *
3190 * End of ZMMCH.
3191 *
3192 END
3193 LOGICAL FUNCTION LZE( RI, RJ, LR )
3194 *
3195 * Tests if two arrays are identical.
3196 *
3197 * Auxiliary routine for test program for Level 3 Blas.
3198 *
3199 * -- Written on 8-February-1989.
3200 * Jack Dongarra, Argonne National Laboratory.
3201 * Iain Duff, AERE Harwell.
3202 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3203 * Sven Hammarling, Numerical Algorithms Group Ltd.
3204 *
3205 * .. Scalar Arguments ..
3206 INTEGER LR
3207 * .. Array Arguments ..
3208 COMPLEX*16 RI( * ), RJ( * )
3209 * .. Local Scalars ..
3210 INTEGER I
3211 * .. Executable Statements ..
3212 DO 10 I = 1, LR
3213 IF( RI( I ).NE.RJ( I ) )
3214 $ GO TO 20
3215 10 CONTINUE
3216 LZE = .TRUE.
3217 GO TO 30
3218 20 CONTINUE
3219 LZE = .FALSE.
3220 30 RETURN
3221 *
3222 * End of LZE.
3223 *
3224 END
3225 LOGICAL FUNCTION LZERES( TYPE, UPLO, M, N, AA, AS, LDA )
3226 *
3227 * Tests if selected elements in two arrays are equal.
3228 *
3229 * TYPE is 'GE' or 'HE' or 'SY'.
3230 *
3231 * Auxiliary routine for test program for Level 3 Blas.
3232 *
3233 * -- Written on 8-February-1989.
3234 * Jack Dongarra, Argonne National Laboratory.
3235 * Iain Duff, AERE Harwell.
3236 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3237 * Sven Hammarling, Numerical Algorithms Group Ltd.
3238 *
3239 * .. Scalar Arguments ..
3240 INTEGER LDA, M, N
3241 CHARACTER*1 UPLO
3242 CHARACTER*2 TYPE
3243 * .. Array Arguments ..
3244 COMPLEX*16 AA( LDA, * ), AS( LDA, * )
3245 * .. Local Scalars ..
3246 INTEGER I, IBEG, IEND, J
3247 LOGICAL UPPER
3248 * .. Executable Statements ..
3249 UPPER = UPLO.EQ.'U'
3250 IF( TYPE.EQ.'GE' )THEN
3251 DO 20 J = 1, N
3252 DO 10 I = M + 1, LDA
3253 IF( AA( I, J ).NE.AS( I, J ) )
3254 $ GO TO 70
3255 10 CONTINUE
3256 20 CONTINUE
3257 ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY' )THEN
3258 DO 50 J = 1, N
3259 IF( UPPER )THEN
3260 IBEG = 1
3261 IEND = J
3262 ELSE
3263 IBEG = J
3264 IEND = N
3265 END IF
3266 DO 30 I = 1, IBEG - 1
3267 IF( AA( I, J ).NE.AS( I, J ) )
3268 $ GO TO 70
3269 30 CONTINUE
3270 DO 40 I = IEND + 1, LDA
3271 IF( AA( I, J ).NE.AS( I, J ) )
3272 $ GO TO 70
3273 40 CONTINUE
3274 50 CONTINUE
3275 END IF
3276 *
3277 60 CONTINUE
3278 LZERES = .TRUE.
3279 GO TO 80
3280 70 CONTINUE
3281 LZERES = .FALSE.
3282 80 RETURN
3283 *
3284 * End of LZERES.
3285 *
3286 END
3287 COMPLEX*16 FUNCTION ZBEG( RESET )
3288 *
3289 * Generates complex numbers as pairs of random numbers uniformly
3290 * distributed between -0.5 and 0.5.
3291 *
3292 * Auxiliary routine for test program for Level 3 Blas.
3293 *
3294 * -- Written on 8-February-1989.
3295 * Jack Dongarra, Argonne National Laboratory.
3296 * Iain Duff, AERE Harwell.
3297 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3298 * Sven Hammarling, Numerical Algorithms Group Ltd.
3299 *
3300 * .. Scalar Arguments ..
3301 LOGICAL RESET
3302 * .. Local Scalars ..
3303 INTEGER I, IC, J, MI, MJ
3304 * .. Save statement ..
3305 SAVE I, IC, J, MI, MJ
3306 * .. Intrinsic Functions ..
3307 INTRINSIC DCMPLX
3308 * .. Executable Statements ..
3309 IF( RESET )THEN
3310 * Initialize local variables.
3311 MI = 891
3312 MJ = 457
3313 I = 7
3314 J = 7
3315 IC = 0
3316 RESET = .FALSE.
3317 END IF
3318 *
3319 * The sequence of values of I or J is bounded between 1 and 999.
3320 * If initial I or J = 1,2,3,6,7 or 9, the period will be 50.
3321 * If initial I or J = 4 or 8, the period will be 25.
3322 * If initial I or J = 5, the period will be 10.
3323 * IC is used to break up the period by skipping 1 value of I or J
3324 * in 6.
3325 *
3326 IC = IC + 1
3327 10 I = I*MI
3328 J = J*MJ
3329 I = I - 1000*( I/1000 )
3330 J = J - 1000*( J/1000 )
3331 IF( IC.GE.5 )THEN
3332 IC = 0
3333 GO TO 10
3334 END IF
3335 ZBEG = DCMPLX( ( I - 500 )/1001.0D0, ( J - 500 )/1001.0D0 )
3336 RETURN
3337 *
3338 * End of ZBEG.
3339 *
3340 END
3341 DOUBLE PRECISION FUNCTION DDIFF( X, Y )
3342 *
3343 * Auxiliary routine for test program for Level 3 Blas.
3344 *
3345 * -- Written on 8-February-1989.
3346 * Jack Dongarra, Argonne National Laboratory.
3347 * Iain Duff, AERE Harwell.
3348 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3349 * Sven Hammarling, Numerical Algorithms Group Ltd.
3350 *
3351 * .. Scalar Arguments ..
3352 DOUBLE PRECISION X, Y
3353 * .. Executable Statements ..
3354 DDIFF = X - Y
3355 RETURN
3356 *
3357 * End of DDIFF.
3358 *
3359 END
3360 SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
3361 *
3362 * Tests whether XERBLA has detected an error when it should.
3363 *
3364 * Auxiliary routine for test program for Level 3 Blas.
3365 *
3366 * -- Written on 8-February-1989.
3367 * Jack Dongarra, Argonne National Laboratory.
3368 * Iain Duff, AERE Harwell.
3369 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3370 * Sven Hammarling, Numerical Algorithms Group Ltd.
3371 *
3372 * .. Scalar Arguments ..
3373 INTEGER INFOT, NOUT
3374 LOGICAL LERR, OK
3375 CHARACTER*6 SRNAMT
3376 * .. Executable Statements ..
3377 IF( .NOT.LERR )THEN
3378 WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
3379 OK = .FALSE.
3380 END IF
3381 LERR = .FALSE.
3382 RETURN
3383 *
3384 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
3385 $ 'ETECTED BY ', A6, ' *****' )
3386 *
3387 * End of CHKXER.
3388 *
3389 END
3390 SUBROUTINE XERBLA( SRNAME, INFO )
3391 *
3392 * This is a special version of XERBLA to be used only as part of
3393 * the test program for testing error exits from the Level 3 BLAS
3394 * routines.
3395 *
3396 * XERBLA is an error handler for the Level 3 BLAS routines.
3397 *
3398 * It is called by the Level 3 BLAS routines if an input parameter is
3399 * invalid.
3400 *
3401 * Auxiliary routine for test program for Level 3 Blas.
3402 *
3403 * -- Written on 8-February-1989.
3404 * Jack Dongarra, Argonne National Laboratory.
3405 * Iain Duff, AERE Harwell.
3406 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3407 * Sven Hammarling, Numerical Algorithms Group Ltd.
3408 *
3409 * .. Scalar Arguments ..
3410 INTEGER INFO
3411 CHARACTER*6 SRNAME
3412 * .. Scalars in Common ..
3413 INTEGER INFOT, NOUT
3414 LOGICAL LERR, OK
3415 CHARACTER*6 SRNAMT
3416 * .. Common blocks ..
3417 COMMON /INFOC/INFOT, NOUT, OK, LERR
3418 COMMON /SRNAMC/SRNAMT
3419 * .. Executable Statements ..
3420 LERR = .TRUE.
3421 IF( INFO.NE.INFOT )THEN
3422 IF( INFOT.NE.0 )THEN
3423 WRITE( NOUT, FMT = 9999 )INFO, INFOT
3424 ELSE
3425 WRITE( NOUT, FMT = 9997 )INFO
3426 END IF
3427 OK = .FALSE.
3428 END IF
3429 IF( SRNAME.NE.SRNAMT )THEN
3430 WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
3431 OK = .FALSE.
3432 END IF
3433 RETURN
3434 *
3435 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
3436 $ ' OF ', I2, ' *******' )
3437 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
3438 $ 'AD OF ', A6, ' *******' )
3439 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
3440 $ ' *******' )
3441 *
3442 * End of XERBLA
3443 *
3444 END
3445
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 14 records
6 * of the file are read using list-directed input, the last 9 records
7 * are read using the format ( A6, L2 ). An annotated example of a data
8 * file can be obtained by deleting the first 3 characters from the
9 * following 23 lines:
10 * 'ZBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE
11 * 6 UNIT NUMBER OF SUMMARY FILE
12 * 'ZBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
13 * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
14 * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
15 * F LOGICAL FLAG, T TO STOP ON FAILURES.
16 * T LOGICAL FLAG, T TO TEST ERROR EXITS.
17 * 16.0 THRESHOLD VALUE OF TEST RATIO
18 * 6 NUMBER OF VALUES OF N
19 * 0 1 2 3 5 9 VALUES OF N
20 * 3 NUMBER OF VALUES OF ALPHA
21 * (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
22 * 3 NUMBER OF VALUES OF BETA
23 * (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
24 * ZGEMM T PUT F FOR NO TEST. SAME COLUMNS.
25 * ZHEMM T PUT F FOR NO TEST. SAME COLUMNS.
26 * ZSYMM T PUT F FOR NO TEST. SAME COLUMNS.
27 * ZTRMM T PUT F FOR NO TEST. SAME COLUMNS.
28 * ZTRSM T PUT F FOR NO TEST. SAME COLUMNS.
29 * ZHERK T PUT F FOR NO TEST. SAME COLUMNS.
30 * ZSYRK T PUT F FOR NO TEST. SAME COLUMNS.
31 * ZHER2K T PUT F FOR NO TEST. SAME COLUMNS.
32 * ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
33 *
34 * See:
35 *
36 * Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
37 * A Set of Level 3 Basic Linear Algebra Subprograms.
38 *
39 * Technical Memorandum No.88 (Revision 1), Mathematics and
40 * Computer Science Division, Argonne National Laboratory, 9700
41 * South Cass Avenue, Argonne, Illinois 60439, US.
42 *
43 * -- Written on 8-February-1989.
44 * Jack Dongarra, Argonne National Laboratory.
45 * Iain Duff, AERE Harwell.
46 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
47 * Sven Hammarling, Numerical Algorithms Group Ltd.
48 *
49 * .. Parameters ..
50 INTEGER NIN
51 PARAMETER ( NIN = 5 )
52 INTEGER NSUBS
53 PARAMETER ( NSUBS = 9 )
54 COMPLEX*16 ZERO, ONE
55 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ),
56 $ ONE = ( 1.0D0, 0.0D0 ) )
57 DOUBLE PRECISION RZERO, RHALF, RONE
58 PARAMETER ( RZERO = 0.0D0, RHALF = 0.5D0, RONE = 1.0D0 )
59 INTEGER NMAX
60 PARAMETER ( NMAX = 65 )
61 INTEGER NIDMAX, NALMAX, NBEMAX
62 PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 )
63 * .. Local Scalars ..
64 DOUBLE PRECISION EPS, ERR, THRESH
65 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA
66 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
67 $ TSTERR
68 CHARACTER*1 TRANSA, TRANSB
69 CHARACTER*6 SNAMET
70 CHARACTER*32 SNAPS, SUMMRY
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*6 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, ZCHKE, ZMMCH
88 * .. Intrinsic Functions ..
89 INTRINSIC MAX, MIN
90 * .. Scalars in Common ..
91 INTEGER INFOT, NOUTC
92 LOGICAL LERR, OK
93 CHARACTER*6 SRNAMT
94 * .. Common blocks ..
95 COMMON /INFOC/INFOT, NOUTC, OK, LERR
96 COMMON /SRNAMC/SRNAMT
97 * .. Data statements ..
98 DATA SNAMES/'ZGEMM ', 'ZHEMM ', 'ZSYMM ', 'ZTRMM ',
99 $ 'ZTRSM ', 'ZHERK ', 'ZSYRK ', 'ZHER2K',
100 $ 'ZSYR2K'/
101 * .. Executable Statements ..
102 *
103 * Read name and unit number for summary output file and open file.
104 *
105 READ( NIN, FMT = * )SUMMRY
106 READ( NIN, FMT = * )NOUT
107 OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
108 NOUTC = NOUT
109 *
110 * Read name and unit number for snapshot output file and open file.
111 *
112 READ( NIN, FMT = * )SNAPS
113 READ( NIN, FMT = * )NTRA
114 TRACE = NTRA.GE.0
115 IF( TRACE )THEN
116 OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
117 END IF
118 * Read the flag that directs rewinding of the snapshot file.
119 READ( NIN, FMT = * )REWI
120 REWI = REWI.AND.TRACE
121 * Read the flag that directs stopping on any failure.
122 READ( NIN, FMT = * )SFATAL
123 * Read the flag that indicates whether error exits are to be tested.
124 READ( NIN, FMT = * )TSTERR
125 * Read the threshold value of the test ratio
126 READ( NIN, FMT = * )THRESH
127 *
128 * Read and check the parameter values for the tests.
129 *
130 * Values of N
131 READ( NIN, FMT = * )NIDIM
132 IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
133 WRITE( NOUT, FMT = 9997 )'N', NIDMAX
134 GO TO 220
135 END IF
136 READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
137 DO 10 I = 1, NIDIM
138 IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
139 WRITE( NOUT, FMT = 9996 )NMAX
140 GO TO 220
141 END IF
142 10 CONTINUE
143 * Values of ALPHA
144 READ( NIN, FMT = * )NALF
145 IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
146 WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
147 GO TO 220
148 END IF
149 READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
150 * Values of BETA
151 READ( NIN, FMT = * )NBET
152 IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
153 WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
154 GO TO 220
155 END IF
156 READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
157 *
158 * Report values of parameters.
159 *
160 WRITE( NOUT, FMT = 9995 )
161 WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM )
162 WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF )
163 WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET )
164 IF( .NOT.TSTERR )THEN
165 WRITE( NOUT, FMT = * )
166 WRITE( NOUT, FMT = 9984 )
167 END IF
168 WRITE( NOUT, FMT = * )
169 WRITE( NOUT, FMT = 9999 )THRESH
170 WRITE( NOUT, FMT = * )
171 *
172 * Read names of subroutines and flags which indicate
173 * whether they are to be tested.
174 *
175 DO 20 I = 1, NSUBS
176 LTEST( I ) = .FALSE.
177 20 CONTINUE
178 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT
179 DO 40 I = 1, NSUBS
180 IF( SNAMET.EQ.SNAMES( I ) )
181 $ GO TO 50
182 40 CONTINUE
183 WRITE( NOUT, FMT = 9990 )SNAMET
184 STOP
185 50 LTEST( I ) = LTESTT
186 GO TO 30
187 *
188 60 CONTINUE
189 CLOSE ( NIN )
190 *
191 * Compute EPS (the machine precision).
192 *
193 EPS = RONE
194 70 CONTINUE
195 IF( DDIFF( RONE + EPS, RONE ).EQ.RZERO )
196 $ GO TO 80
197 EPS = RHALF*EPS
198 GO TO 70
199 80 CONTINUE
200 EPS = EPS + EPS
201 WRITE( NOUT, FMT = 9998 )EPS
202 *
203 * Check the reliability of ZMMCH using exact data.
204 *
205 N = MIN( 32, NMAX )
206 DO 100 J = 1, N
207 DO 90 I = 1, N
208 AB( I, J ) = MAX( I - J + 1, 0 )
209 90 CONTINUE
210 AB( J, NMAX + 1 ) = J
211 AB( 1, NMAX + J ) = J
212 C( J, 1 ) = ZERO
213 100 CONTINUE
214 DO 110 J = 1, N
215 CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
216 110 CONTINUE
217 * CC holds the exact result. On exit from ZMMCH CT holds
218 * the result computed by ZMMCH.
219 TRANSA = 'N'
220 TRANSB = 'N'
221 CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
222 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
223 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
224 SAME = LZE( CC, CT, N )
225 IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
226 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
227 STOP
228 END IF
229 TRANSB = 'C'
230 CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
231 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
232 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
233 SAME = LZE( CC, CT, N )
234 IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
235 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
236 STOP
237 END IF
238 DO 120 J = 1, N
239 AB( J, NMAX + 1 ) = N - J + 1
240 AB( 1, NMAX + J ) = N - J + 1
241 120 CONTINUE
242 DO 130 J = 1, N
243 CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 -
244 $ ( ( J + 1 )*J*( J - 1 ) )/3
245 130 CONTINUE
246 TRANSA = 'C'
247 TRANSB = 'N'
248 CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
249 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
250 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
251 SAME = LZE( CC, CT, N )
252 IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
253 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
254 STOP
255 END IF
256 TRANSB = 'C'
257 CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
258 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
259 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
260 SAME = LZE( CC, CT, N )
261 IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
262 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
263 STOP
264 END IF
265 *
266 * Test each subroutine in turn.
267 *
268 DO 200 ISNUM = 1, NSUBS
269 WRITE( NOUT, FMT = * )
270 IF( .NOT.LTEST( ISNUM ) )THEN
271 * Subprogram is not to be tested.
272 WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM )
273 ELSE
274 SRNAMT = SNAMES( ISNUM )
275 * Test error exits.
276 IF( TSTERR )THEN
277 CALL ZCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
278 WRITE( NOUT, FMT = * )
279 END IF
280 * Test computations.
281 INFOT = 0
282 OK = .TRUE.
283 FATAL = .FALSE.
284 GO TO ( 140, 150, 150, 160, 160, 170, 170,
285 $ 180, 180 )ISNUM
286 * Test ZGEMM, 01.
287 140 CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
288 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
289 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
290 $ CC, CS, CT, G )
291 GO TO 190
292 * Test ZHEMM, 02, ZSYMM, 03.
293 150 CALL ZCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
294 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
295 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
296 $ CC, CS, CT, G )
297 GO TO 190
298 * Test ZTRMM, 04, ZTRSM, 05.
299 160 CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
300 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
301 $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C )
302 GO TO 190
303 * Test ZHERK, 06, ZSYRK, 07.
304 170 CALL ZCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
305 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
306 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
307 $ CC, CS, CT, G )
308 GO TO 190
309 * Test ZHER2K, 08, ZSYR2K, 09.
310 180 CALL ZCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
311 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
312 $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
313 GO TO 190
314 *
315 190 IF( FATAL.AND.SFATAL )
316 $ GO TO 210
317 END IF
318 200 CONTINUE
319 WRITE( NOUT, FMT = 9986 )
320 GO TO 230
321 *
322 210 CONTINUE
323 WRITE( NOUT, FMT = 9985 )
324 GO TO 230
325 *
326 220 CONTINUE
327 WRITE( NOUT, FMT = 9991 )
328 *
329 230 CONTINUE
330 IF( TRACE )
331 $ CLOSE ( NTRA )
332 CLOSE ( NOUT )
333 STOP
334 *
335 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
336 $ 'S THAN', F8.2 )
337 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
338 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
339 $ 'THAN ', I2 )
340 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
341 9995 FORMAT( ' TESTS OF THE COMPLEX*16 LEVEL 3 BLAS', //' THE F',
342 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
343 9994 FORMAT( ' FOR N ', 9I6 )
344 9993 FORMAT( ' FOR ALPHA ',
345 $ 7( '(', F4.1, ',', F4.1, ') ', : ) )
346 9992 FORMAT( ' FOR BETA ',
347 $ 7( '(', F4.1, ',', F4.1, ') ', : ) )
348 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
349 $ /' ******* TESTS ABANDONED *******' )
350 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
351 $ 'ESTS ABANDONED *******' )
352 9989 FORMAT( ' ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
353 $ 'ATED WRONGLY.', /' ZMMCH WAS CALLED WITH TRANSA = ', A1,
354 $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',
355 $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
356 $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
357 $ '*******' )
358 9988 FORMAT( A6, L2 )
359 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' )
360 9986 FORMAT( /' END OF TESTS' )
361 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
362 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
363 *
364 * End of ZBLAT3.
365 *
366 END
367 SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
368 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
369 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
370 *
371 * Tests ZGEMM.
372 *
373 * Auxiliary routine for test program for Level 3 Blas.
374 *
375 * -- Written on 8-February-1989.
376 * Jack Dongarra, Argonne National Laboratory.
377 * Iain Duff, AERE Harwell.
378 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
379 * Sven Hammarling, Numerical Algorithms Group Ltd.
380 *
381 * .. Parameters ..
382 COMPLEX*16 ZERO
383 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) )
384 DOUBLE PRECISION RZERO
385 PARAMETER ( RZERO = 0.0D0 )
386 * .. Scalar Arguments ..
387 DOUBLE PRECISION EPS, THRESH
388 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
389 LOGICAL FATAL, REWI, TRACE
390 CHARACTER*6 SNAME
391 * .. Array Arguments ..
392 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
393 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
394 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
395 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
396 $ CS( NMAX*NMAX ), CT( NMAX )
397 DOUBLE PRECISION G( NMAX )
398 INTEGER IDIM( NIDIM )
399 * .. Local Scalars ..
400 COMPLEX*16 ALPHA, ALS, BETA, BLS
401 DOUBLE PRECISION ERR, ERRMAX
402 INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
403 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
404 $ MA, MB, MS, N, NA, NARGS, NB, NC, NS
405 LOGICAL NULL, RESET, SAME, TRANA, TRANB
406 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
407 CHARACTER*3 ICH
408 * .. Local Arrays ..
409 LOGICAL ISAME( 13 )
410 * .. External Functions ..
411 LOGICAL LZE, LZERES
412 EXTERNAL LZE, LZERES
413 * .. External Subroutines ..
414 EXTERNAL ZGEMM, ZMAKE, ZMMCH
415 * .. Intrinsic Functions ..
416 INTRINSIC MAX
417 * .. Scalars in Common ..
418 INTEGER INFOT, NOUTC
419 LOGICAL LERR, OK
420 * .. Common blocks ..
421 COMMON /INFOC/INFOT, NOUTC, OK, LERR
422 * .. Data statements ..
423 DATA ICH/'NTC'/
424 * .. Executable Statements ..
425 *
426 NARGS = 13
427 NC = 0
428 RESET = .TRUE.
429 ERRMAX = RZERO
430 *
431 DO 110 IM = 1, NIDIM
432 M = IDIM( IM )
433 *
434 DO 100 IN = 1, NIDIM
435 N = IDIM( IN )
436 * Set LDC to 1 more than minimum value if room.
437 LDC = M
438 IF( LDC.LT.NMAX )
439 $ LDC = LDC + 1
440 * Skip tests if not enough room.
441 IF( LDC.GT.NMAX )
442 $ GO TO 100
443 LCC = LDC*N
444 NULL = N.LE.0.OR.M.LE.0
445 *
446 DO 90 IK = 1, NIDIM
447 K = IDIM( IK )
448 *
449 DO 80 ICA = 1, 3
450 TRANSA = ICH( ICA: ICA )
451 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
452 *
453 IF( TRANA )THEN
454 MA = K
455 NA = M
456 ELSE
457 MA = M
458 NA = K
459 END IF
460 * Set LDA to 1 more than minimum value if room.
461 LDA = MA
462 IF( LDA.LT.NMAX )
463 $ LDA = LDA + 1
464 * Skip tests if not enough room.
465 IF( LDA.GT.NMAX )
466 $ GO TO 80
467 LAA = LDA*NA
468 *
469 * Generate the matrix A.
470 *
471 CALL ZMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
472 $ RESET, ZERO )
473 *
474 DO 70 ICB = 1, 3
475 TRANSB = ICH( ICB: ICB )
476 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
477 *
478 IF( TRANB )THEN
479 MB = N
480 NB = K
481 ELSE
482 MB = K
483 NB = N
484 END IF
485 * Set LDB to 1 more than minimum value if room.
486 LDB = MB
487 IF( LDB.LT.NMAX )
488 $ LDB = LDB + 1
489 * Skip tests if not enough room.
490 IF( LDB.GT.NMAX )
491 $ GO TO 70
492 LBB = LDB*NB
493 *
494 * Generate the matrix B.
495 *
496 CALL ZMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB,
497 $ LDB, RESET, ZERO )
498 *
499 DO 60 IA = 1, NALF
500 ALPHA = ALF( IA )
501 *
502 DO 50 IB = 1, NBET
503 BETA = BET( IB )
504 *
505 * Generate the matrix C.
506 *
507 CALL ZMAKE( 'GE', ' ', ' ', M, N, C, NMAX,
508 $ CC, LDC, RESET, ZERO )
509 *
510 NC = NC + 1
511 *
512 * Save every datum before calling the
513 * subroutine.
514 *
515 TRANAS = TRANSA
516 TRANBS = TRANSB
517 MS = M
518 NS = N
519 KS = K
520 ALS = ALPHA
521 DO 10 I = 1, LAA
522 AS( I ) = AA( I )
523 10 CONTINUE
524 LDAS = LDA
525 DO 20 I = 1, LBB
526 BS( I ) = BB( I )
527 20 CONTINUE
528 LDBS = LDB
529 BLS = BETA
530 DO 30 I = 1, LCC
531 CS( I ) = CC( I )
532 30 CONTINUE
533 LDCS = LDC
534 *
535 * Call the subroutine.
536 *
537 IF( TRACE )
538 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
539 $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB,
540 $ BETA, LDC
541 IF( REWI )
542 $ REWIND NTRA
543 CALL ZGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
544 $ AA, LDA, BB, LDB, BETA, CC, LDC )
545 *
546 * Check if error-exit was taken incorrectly.
547 *
548 IF( .NOT.OK )THEN
549 WRITE( NOUT, FMT = 9994 )
550 FATAL = .TRUE.
551 GO TO 120
552 END IF
553 *
554 * See what data changed inside subroutines.
555 *
556 ISAME( 1 ) = TRANSA.EQ.TRANAS
557 ISAME( 2 ) = TRANSB.EQ.TRANBS
558 ISAME( 3 ) = MS.EQ.M
559 ISAME( 4 ) = NS.EQ.N
560 ISAME( 5 ) = KS.EQ.K
561 ISAME( 6 ) = ALS.EQ.ALPHA
562 ISAME( 7 ) = LZE( AS, AA, LAA )
563 ISAME( 8 ) = LDAS.EQ.LDA
564 ISAME( 9 ) = LZE( BS, BB, LBB )
565 ISAME( 10 ) = LDBS.EQ.LDB
566 ISAME( 11 ) = BLS.EQ.BETA
567 IF( NULL )THEN
568 ISAME( 12 ) = LZE( CS, CC, LCC )
569 ELSE
570 ISAME( 12 ) = LZERES( 'GE', ' ', M, N, CS,
571 $ CC, LDC )
572 END IF
573 ISAME( 13 ) = LDCS.EQ.LDC
574 *
575 * If data was incorrectly changed, report
576 * and return.
577 *
578 SAME = .TRUE.
579 DO 40 I = 1, NARGS
580 SAME = SAME.AND.ISAME( I )
581 IF( .NOT.ISAME( I ) )
582 $ WRITE( NOUT, FMT = 9998 )I
583 40 CONTINUE
584 IF( .NOT.SAME )THEN
585 FATAL = .TRUE.
586 GO TO 120
587 END IF
588 *
589 IF( .NOT.NULL )THEN
590 *
591 * Check the result.
592 *
593 CALL ZMMCH( TRANSA, TRANSB, M, N, K,
594 $ ALPHA, A, NMAX, B, NMAX, BETA,
595 $ C, NMAX, CT, G, CC, LDC, EPS,
596 $ ERR, FATAL, NOUT, .TRUE. )
597 ERRMAX = MAX( ERRMAX, ERR )
598 * If got really bad answer, report and
599 * return.
600 IF( FATAL )
601 $ GO TO 120
602 END IF
603 *
604 50 CONTINUE
605 *
606 60 CONTINUE
607 *
608 70 CONTINUE
609 *
610 80 CONTINUE
611 *
612 90 CONTINUE
613 *
614 100 CONTINUE
615 *
616 110 CONTINUE
617 *
618 * Report result.
619 *
620 IF( ERRMAX.LT.THRESH )THEN
621 WRITE( NOUT, FMT = 9999 )SNAME, NC
622 ELSE
623 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
624 END IF
625 GO TO 130
626 *
627 120 CONTINUE
628 WRITE( NOUT, FMT = 9996 )SNAME
629 WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K,
630 $ ALPHA, LDA, LDB, BETA, LDC
631 *
632 130 CONTINUE
633 RETURN
634 *
635 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
636 $ 'S)' )
637 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
638 $ 'ANGED INCORRECTLY *******' )
639 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
640 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
641 $ ' - SUSPECT *******' )
642 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
643 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',',
644 $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
645 $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
646 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
647 $ '******' )
648 *
649 * End of ZCHK1.
650 *
651 END
652 SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
653 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
654 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
655 *
656 * Tests ZHEMM and ZSYMM.
657 *
658 * Auxiliary routine for test program for Level 3 Blas.
659 *
660 * -- Written on 8-February-1989.
661 * Jack Dongarra, Argonne National Laboratory.
662 * Iain Duff, AERE Harwell.
663 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
664 * Sven Hammarling, Numerical Algorithms Group Ltd.
665 *
666 * .. Parameters ..
667 COMPLEX*16 ZERO
668 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) )
669 DOUBLE PRECISION RZERO
670 PARAMETER ( RZERO = 0.0D0 )
671 * .. Scalar Arguments ..
672 DOUBLE PRECISION EPS, THRESH
673 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
674 LOGICAL FATAL, REWI, TRACE
675 CHARACTER*6 SNAME
676 * .. Array Arguments ..
677 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
678 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
679 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
680 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
681 $ CS( NMAX*NMAX ), CT( NMAX )
682 DOUBLE PRECISION G( NMAX )
683 INTEGER IDIM( NIDIM )
684 * .. Local Scalars ..
685 COMPLEX*16 ALPHA, ALS, BETA, BLS
686 DOUBLE PRECISION ERR, ERRMAX
687 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
688 $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
689 $ NARGS, NC, NS
690 LOGICAL CONJ, LEFT, NULL, RESET, SAME
691 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
692 CHARACTER*2 ICHS, ICHU
693 * .. Local Arrays ..
694 LOGICAL ISAME( 13 )
695 * .. External Functions ..
696 LOGICAL LZE, LZERES
697 EXTERNAL LZE, LZERES
698 * .. External Subroutines ..
699 EXTERNAL ZHEMM, ZMAKE, ZMMCH, ZSYMM
700 * .. Intrinsic Functions ..
701 INTRINSIC MAX
702 * .. Scalars in Common ..
703 INTEGER INFOT, NOUTC
704 LOGICAL LERR, OK
705 * .. Common blocks ..
706 COMMON /INFOC/INFOT, NOUTC, OK, LERR
707 * .. Data statements ..
708 DATA ICHS/'LR'/, ICHU/'UL'/
709 * .. Executable Statements ..
710 CONJ = SNAME( 2: 3 ).EQ.'HE'
711 *
712 NARGS = 12
713 NC = 0
714 RESET = .TRUE.
715 ERRMAX = RZERO
716 *
717 DO 100 IM = 1, NIDIM
718 M = IDIM( IM )
719 *
720 DO 90 IN = 1, NIDIM
721 N = IDIM( IN )
722 * Set LDC to 1 more than minimum value if room.
723 LDC = M
724 IF( LDC.LT.NMAX )
725 $ LDC = LDC + 1
726 * Skip tests if not enough room.
727 IF( LDC.GT.NMAX )
728 $ GO TO 90
729 LCC = LDC*N
730 NULL = N.LE.0.OR.M.LE.0
731 * Set LDB to 1 more than minimum value if room.
732 LDB = M
733 IF( LDB.LT.NMAX )
734 $ LDB = LDB + 1
735 * Skip tests if not enough room.
736 IF( LDB.GT.NMAX )
737 $ GO TO 90
738 LBB = LDB*N
739 *
740 * Generate the matrix B.
741 *
742 CALL ZMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET,
743 $ ZERO )
744 *
745 DO 80 ICS = 1, 2
746 SIDE = ICHS( ICS: ICS )
747 LEFT = SIDE.EQ.'L'
748 *
749 IF( LEFT )THEN
750 NA = M
751 ELSE
752 NA = N
753 END IF
754 * Set LDA to 1 more than minimum value if room.
755 LDA = NA
756 IF( LDA.LT.NMAX )
757 $ LDA = LDA + 1
758 * Skip tests if not enough room.
759 IF( LDA.GT.NMAX )
760 $ GO TO 80
761 LAA = LDA*NA
762 *
763 DO 70 ICU = 1, 2
764 UPLO = ICHU( ICU: ICU )
765 *
766 * Generate the hermitian or symmetric matrix A.
767 *
768 CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', NA, NA, A, NMAX,
769 $ AA, LDA, RESET, ZERO )
770 *
771 DO 60 IA = 1, NALF
772 ALPHA = ALF( IA )
773 *
774 DO 50 IB = 1, NBET
775 BETA = BET( IB )
776 *
777 * Generate the matrix C.
778 *
779 CALL ZMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC,
780 $ LDC, RESET, ZERO )
781 *
782 NC = NC + 1
783 *
784 * Save every datum before calling the
785 * subroutine.
786 *
787 SIDES = SIDE
788 UPLOS = UPLO
789 MS = M
790 NS = N
791 ALS = ALPHA
792 DO 10 I = 1, LAA
793 AS( I ) = AA( I )
794 10 CONTINUE
795 LDAS = LDA
796 DO 20 I = 1, LBB
797 BS( I ) = BB( I )
798 20 CONTINUE
799 LDBS = LDB
800 BLS = BETA
801 DO 30 I = 1, LCC
802 CS( I ) = CC( I )
803 30 CONTINUE
804 LDCS = LDC
805 *
806 * Call the subroutine.
807 *
808 IF( TRACE )
809 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE,
810 $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC
811 IF( REWI )
812 $ REWIND NTRA
813 IF( CONJ )THEN
814 CALL ZHEMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
815 $ BB, LDB, BETA, CC, LDC )
816 ELSE
817 CALL ZSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
818 $ BB, LDB, BETA, CC, LDC )
819 END IF
820 *
821 * Check if error-exit was taken incorrectly.
822 *
823 IF( .NOT.OK )THEN
824 WRITE( NOUT, FMT = 9994 )
825 FATAL = .TRUE.
826 GO TO 110
827 END IF
828 *
829 * See what data changed inside subroutines.
830 *
831 ISAME( 1 ) = SIDES.EQ.SIDE
832 ISAME( 2 ) = UPLOS.EQ.UPLO
833 ISAME( 3 ) = MS.EQ.M
834 ISAME( 4 ) = NS.EQ.N
835 ISAME( 5 ) = ALS.EQ.ALPHA
836 ISAME( 6 ) = LZE( AS, AA, LAA )
837 ISAME( 7 ) = LDAS.EQ.LDA
838 ISAME( 8 ) = LZE( BS, BB, LBB )
839 ISAME( 9 ) = LDBS.EQ.LDB
840 ISAME( 10 ) = BLS.EQ.BETA
841 IF( NULL )THEN
842 ISAME( 11 ) = LZE( CS, CC, LCC )
843 ELSE
844 ISAME( 11 ) = LZERES( 'GE', ' ', M, N, CS,
845 $ CC, LDC )
846 END IF
847 ISAME( 12 ) = LDCS.EQ.LDC
848 *
849 * If data was incorrectly changed, report and
850 * return.
851 *
852 SAME = .TRUE.
853 DO 40 I = 1, NARGS
854 SAME = SAME.AND.ISAME( I )
855 IF( .NOT.ISAME( I ) )
856 $ WRITE( NOUT, FMT = 9998 )I
857 40 CONTINUE
858 IF( .NOT.SAME )THEN
859 FATAL = .TRUE.
860 GO TO 110
861 END IF
862 *
863 IF( .NOT.NULL )THEN
864 *
865 * Check the result.
866 *
867 IF( LEFT )THEN
868 CALL ZMMCH( 'N', 'N', M, N, M, ALPHA, A,
869 $ NMAX, B, NMAX, BETA, C, NMAX,
870 $ CT, G, CC, LDC, EPS, ERR,
871 $ FATAL, NOUT, .TRUE. )
872 ELSE
873 CALL ZMMCH( 'N', 'N', M, N, N, ALPHA, B,
874 $ NMAX, A, NMAX, BETA, C, NMAX,
875 $ CT, G, CC, LDC, EPS, ERR,
876 $ FATAL, NOUT, .TRUE. )
877 END IF
878 ERRMAX = MAX( ERRMAX, ERR )
879 * If got really bad answer, report and
880 * return.
881 IF( FATAL )
882 $ GO TO 110
883 END IF
884 *
885 50 CONTINUE
886 *
887 60 CONTINUE
888 *
889 70 CONTINUE
890 *
891 80 CONTINUE
892 *
893 90 CONTINUE
894 *
895 100 CONTINUE
896 *
897 * Report result.
898 *
899 IF( ERRMAX.LT.THRESH )THEN
900 WRITE( NOUT, FMT = 9999 )SNAME, NC
901 ELSE
902 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
903 END IF
904 GO TO 120
905 *
906 110 CONTINUE
907 WRITE( NOUT, FMT = 9996 )SNAME
908 WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA,
909 $ LDB, BETA, LDC
910 *
911 120 CONTINUE
912 RETURN
913 *
914 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
915 $ 'S)' )
916 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
917 $ 'ANGED INCORRECTLY *******' )
918 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
919 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
920 $ ' - SUSPECT *******' )
921 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
922 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
923 $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
924 $ ',', F4.1, '), C,', I3, ') .' )
925 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
926 $ '******' )
927 *
928 * End of ZCHK2.
929 *
930 END
931 SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
932 $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS,
933 $ B, BB, BS, CT, G, C )
934 *
935 * Tests ZTRMM and ZTRSM.
936 *
937 * Auxiliary routine for test program for Level 3 Blas.
938 *
939 * -- Written on 8-February-1989.
940 * Jack Dongarra, Argonne National Laboratory.
941 * Iain Duff, AERE Harwell.
942 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
943 * Sven Hammarling, Numerical Algorithms Group Ltd.
944 *
945 * .. Parameters ..
946 COMPLEX*16 ZERO, ONE
947 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ),
948 $ ONE = ( 1.0D0, 0.0D0 ) )
949 DOUBLE PRECISION RZERO
950 PARAMETER ( RZERO = 0.0D0 )
951 * .. Scalar Arguments ..
952 DOUBLE PRECISION EPS, THRESH
953 INTEGER NALF, NIDIM, NMAX, NOUT, NTRA
954 LOGICAL FATAL, REWI, TRACE
955 CHARACTER*6 SNAME
956 * .. Array Arguments ..
957 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
958 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
959 $ BB( NMAX*NMAX ), BS( NMAX*NMAX ),
960 $ C( NMAX, NMAX ), CT( NMAX )
961 DOUBLE PRECISION G( NMAX )
962 INTEGER IDIM( NIDIM )
963 * .. Local Scalars ..
964 COMPLEX*16 ALPHA, ALS
965 DOUBLE PRECISION ERR, ERRMAX
966 INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
967 $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
968 $ NS
969 LOGICAL LEFT, NULL, RESET, SAME
970 CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
971 $ UPLOS
972 CHARACTER*2 ICHD, ICHS, ICHU
973 CHARACTER*3 ICHT
974 * .. Local Arrays ..
975 LOGICAL ISAME( 13 )
976 * .. External Functions ..
977 LOGICAL LZE, LZERES
978 EXTERNAL LZE, LZERES
979 * .. External Subroutines ..
980 EXTERNAL ZMAKE, ZMMCH, ZTRMM, ZTRSM
981 * .. Intrinsic Functions ..
982 INTRINSIC MAX
983 * .. Scalars in Common ..
984 INTEGER INFOT, NOUTC
985 LOGICAL LERR, OK
986 * .. Common blocks ..
987 COMMON /INFOC/INFOT, NOUTC, OK, LERR
988 * .. Data statements ..
989 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/
990 * .. Executable Statements ..
991 *
992 NARGS = 11
993 NC = 0
994 RESET = .TRUE.
995 ERRMAX = RZERO
996 * Set up zero matrix for ZMMCH.
997 DO 20 J = 1, NMAX
998 DO 10 I = 1, NMAX
999 C( I, J ) = ZERO
1000 10 CONTINUE
1001 20 CONTINUE
1002 *
1003 DO 140 IM = 1, NIDIM
1004 M = IDIM( IM )
1005 *
1006 DO 130 IN = 1, NIDIM
1007 N = IDIM( IN )
1008 * Set LDB to 1 more than minimum value if room.
1009 LDB = M
1010 IF( LDB.LT.NMAX )
1011 $ LDB = LDB + 1
1012 * Skip tests if not enough room.
1013 IF( LDB.GT.NMAX )
1014 $ GO TO 130
1015 LBB = LDB*N
1016 NULL = M.LE.0.OR.N.LE.0
1017 *
1018 DO 120 ICS = 1, 2
1019 SIDE = ICHS( ICS: ICS )
1020 LEFT = SIDE.EQ.'L'
1021 IF( LEFT )THEN
1022 NA = M
1023 ELSE
1024 NA = N
1025 END IF
1026 * Set LDA to 1 more than minimum value if room.
1027 LDA = NA
1028 IF( LDA.LT.NMAX )
1029 $ LDA = LDA + 1
1030 * Skip tests if not enough room.
1031 IF( LDA.GT.NMAX )
1032 $ GO TO 130
1033 LAA = LDA*NA
1034 *
1035 DO 110 ICU = 1, 2
1036 UPLO = ICHU( ICU: ICU )
1037 *
1038 DO 100 ICT = 1, 3
1039 TRANSA = ICHT( ICT: ICT )
1040 *
1041 DO 90 ICD = 1, 2
1042 DIAG = ICHD( ICD: ICD )
1043 *
1044 DO 80 IA = 1, NALF
1045 ALPHA = ALF( IA )
1046 *
1047 * Generate the matrix A.
1048 *
1049 CALL ZMAKE( 'TR', UPLO, DIAG, NA, NA, A,
1050 $ NMAX, AA, LDA, RESET, ZERO )
1051 *
1052 * Generate the matrix B.
1053 *
1054 CALL ZMAKE( 'GE', ' ', ' ', M, N, B, NMAX,
1055 $ BB, LDB, RESET, ZERO )
1056 *
1057 NC = NC + 1
1058 *
1059 * Save every datum before calling the
1060 * subroutine.
1061 *
1062 SIDES = SIDE
1063 UPLOS = UPLO
1064 TRANAS = TRANSA
1065 DIAGS = DIAG
1066 MS = M
1067 NS = N
1068 ALS = ALPHA
1069 DO 30 I = 1, LAA
1070 AS( I ) = AA( I )
1071 30 CONTINUE
1072 LDAS = LDA
1073 DO 40 I = 1, LBB
1074 BS( I ) = BB( I )
1075 40 CONTINUE
1076 LDBS = LDB
1077 *
1078 * Call the subroutine.
1079 *
1080 IF( SNAME( 4: 5 ).EQ.'MM' )THEN
1081 IF( TRACE )
1082 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1083 $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1084 $ LDA, LDB
1085 IF( REWI )
1086 $ REWIND NTRA
1087 CALL ZTRMM( SIDE, UPLO, TRANSA, DIAG, M,
1088 $ N, ALPHA, AA, LDA, BB, LDB )
1089 ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
1090 IF( TRACE )
1091 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1092 $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1093 $ LDA, LDB
1094 IF( REWI )
1095 $ REWIND NTRA
1096 CALL ZTRSM( SIDE, UPLO, TRANSA, DIAG, M,
1097 $ N, ALPHA, AA, LDA, BB, LDB )
1098 END IF
1099 *
1100 * Check if error-exit was taken incorrectly.
1101 *
1102 IF( .NOT.OK )THEN
1103 WRITE( NOUT, FMT = 9994 )
1104 FATAL = .TRUE.
1105 GO TO 150
1106 END IF
1107 *
1108 * See what data changed inside subroutines.
1109 *
1110 ISAME( 1 ) = SIDES.EQ.SIDE
1111 ISAME( 2 ) = UPLOS.EQ.UPLO
1112 ISAME( 3 ) = TRANAS.EQ.TRANSA
1113 ISAME( 4 ) = DIAGS.EQ.DIAG
1114 ISAME( 5 ) = MS.EQ.M
1115 ISAME( 6 ) = NS.EQ.N
1116 ISAME( 7 ) = ALS.EQ.ALPHA
1117 ISAME( 8 ) = LZE( AS, AA, LAA )
1118 ISAME( 9 ) = LDAS.EQ.LDA
1119 IF( NULL )THEN
1120 ISAME( 10 ) = LZE( BS, BB, LBB )
1121 ELSE
1122 ISAME( 10 ) = LZERES( 'GE', ' ', M, N, BS,
1123 $ BB, LDB )
1124 END IF
1125 ISAME( 11 ) = LDBS.EQ.LDB
1126 *
1127 * If data was incorrectly changed, report and
1128 * return.
1129 *
1130 SAME = .TRUE.
1131 DO 50 I = 1, NARGS
1132 SAME = SAME.AND.ISAME( I )
1133 IF( .NOT.ISAME( I ) )
1134 $ WRITE( NOUT, FMT = 9998 )I
1135 50 CONTINUE
1136 IF( .NOT.SAME )THEN
1137 FATAL = .TRUE.
1138 GO TO 150
1139 END IF
1140 *
1141 IF( .NOT.NULL )THEN
1142 IF( SNAME( 4: 5 ).EQ.'MM' )THEN
1143 *
1144 * Check the result.
1145 *
1146 IF( LEFT )THEN
1147 CALL ZMMCH( TRANSA, 'N', M, N, M,
1148 $ ALPHA, A, NMAX, B, NMAX,
1149 $ ZERO, C, NMAX, CT, G,
1150 $ BB, LDB, EPS, ERR,
1151 $ FATAL, NOUT, .TRUE. )
1152 ELSE
1153 CALL ZMMCH( 'N', TRANSA, M, N, N,
1154 $ ALPHA, B, NMAX, A, NMAX,
1155 $ ZERO, C, NMAX, CT, G,
1156 $ BB, LDB, EPS, ERR,
1157 $ FATAL, NOUT, .TRUE. )
1158 END IF
1159 ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
1160 *
1161 * Compute approximation to original
1162 * matrix.
1163 *
1164 DO 70 J = 1, N
1165 DO 60 I = 1, M
1166 C( I, J ) = BB( I + ( J - 1 )*
1167 $ LDB )
1168 BB( I + ( J - 1 )*LDB ) = ALPHA*
1169 $ B( I, J )
1170 60 CONTINUE
1171 70 CONTINUE
1172 *
1173 IF( LEFT )THEN
1174 CALL ZMMCH( TRANSA, 'N', M, N, M,
1175 $ ONE, A, NMAX, C, NMAX,
1176 $ ZERO, B, NMAX, CT, G,
1177 $ BB, LDB, EPS, ERR,
1178 $ FATAL, NOUT, .FALSE. )
1179 ELSE
1180 CALL ZMMCH( 'N', TRANSA, M, N, N,
1181 $ ONE, C, NMAX, A, NMAX,
1182 $ ZERO, B, NMAX, CT, G,
1183 $ BB, LDB, EPS, ERR,
1184 $ FATAL, NOUT, .FALSE. )
1185 END IF
1186 END IF
1187 ERRMAX = MAX( ERRMAX, ERR )
1188 * If got really bad answer, report and
1189 * return.
1190 IF( FATAL )
1191 $ GO TO 150
1192 END IF
1193 *
1194 80 CONTINUE
1195 *
1196 90 CONTINUE
1197 *
1198 100 CONTINUE
1199 *
1200 110 CONTINUE
1201 *
1202 120 CONTINUE
1203 *
1204 130 CONTINUE
1205 *
1206 140 CONTINUE
1207 *
1208 * Report result.
1209 *
1210 IF( ERRMAX.LT.THRESH )THEN
1211 WRITE( NOUT, FMT = 9999 )SNAME, NC
1212 ELSE
1213 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1214 END IF
1215 GO TO 160
1216 *
1217 150 CONTINUE
1218 WRITE( NOUT, FMT = 9996 )SNAME
1219 WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M,
1220 $ N, ALPHA, LDA, LDB
1221 *
1222 160 CONTINUE
1223 RETURN
1224 *
1225 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1226 $ 'S)' )
1227 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1228 $ 'ANGED INCORRECTLY *******' )
1229 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1230 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1231 $ ' - SUSPECT *******' )
1232 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1233 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ),
1234 $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ',
1235 $ ' .' )
1236 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1237 $ '******' )
1238 *
1239 * End of ZCHK3.
1240 *
1241 END
1242 SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1243 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1244 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
1245 *
1246 * Tests ZHERK and ZSYRK.
1247 *
1248 * Auxiliary routine for test program for Level 3 Blas.
1249 *
1250 * -- Written on 8-February-1989.
1251 * Jack Dongarra, Argonne National Laboratory.
1252 * Iain Duff, AERE Harwell.
1253 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1254 * Sven Hammarling, Numerical Algorithms Group Ltd.
1255 *
1256 * .. Parameters ..
1257 COMPLEX*16 ZERO
1258 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) )
1259 DOUBLE PRECISION RONE, RZERO
1260 PARAMETER ( RONE = 1.0D0, RZERO = 0.0D0 )
1261 * .. Scalar Arguments ..
1262 DOUBLE PRECISION EPS, THRESH
1263 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1264 LOGICAL FATAL, REWI, TRACE
1265 CHARACTER*6 SNAME
1266 * .. Array Arguments ..
1267 COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1268 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1269 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
1270 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
1271 $ CS( NMAX*NMAX ), CT( NMAX )
1272 DOUBLE PRECISION G( NMAX )
1273 INTEGER IDIM( NIDIM )
1274 * .. Local Scalars ..
1275 COMPLEX*16 ALPHA, ALS, BETA, BETS
1276 DOUBLE PRECISION ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS
1277 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1278 $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1279 $ NARGS, NC, NS
1280 LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER
1281 CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS
1282 CHARACTER*2 ICHT, ICHU
1283 * .. Local Arrays ..
1284 LOGICAL ISAME( 13 )
1285 * .. External Functions ..
1286 LOGICAL LZE, LZERES
1287 EXTERNAL LZE, LZERES
1288 * .. External Subroutines ..
1289 EXTERNAL ZHERK, ZMAKE, ZMMCH, ZSYRK
1290 * .. Intrinsic Functions ..
1291 INTRINSIC DCMPLX, MAX, DBLE
1292 * .. Scalars in Common ..
1293 INTEGER INFOT, NOUTC
1294 LOGICAL LERR, OK
1295 * .. Common blocks ..
1296 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1297 * .. Data statements ..
1298 DATA ICHT/'NC'/, ICHU/'UL'/
1299 * .. Executable Statements ..
1300 CONJ = SNAME( 2: 3 ).EQ.'HE'
1301 *
1302 NARGS = 10
1303 NC = 0
1304 RESET = .TRUE.
1305 ERRMAX = RZERO
1306 *
1307 DO 100 IN = 1, NIDIM
1308 N = IDIM( IN )
1309 * Set LDC to 1 more than minimum value if room.
1310 LDC = N
1311 IF( LDC.LT.NMAX )
1312 $ LDC = LDC + 1
1313 * Skip tests if not enough room.
1314 IF( LDC.GT.NMAX )
1315 $ GO TO 100
1316 LCC = LDC*N
1317 *
1318 DO 90 IK = 1, NIDIM
1319 K = IDIM( IK )
1320 *
1321 DO 80 ICT = 1, 2
1322 TRANS = ICHT( ICT: ICT )
1323 TRAN = TRANS.EQ.'C'
1324 IF( TRAN.AND..NOT.CONJ )
1325 $ TRANS = 'T'
1326 IF( TRAN )THEN
1327 MA = K
1328 NA = N
1329 ELSE
1330 MA = N
1331 NA = K
1332 END IF
1333 * Set LDA to 1 more than minimum value if room.
1334 LDA = MA
1335 IF( LDA.LT.NMAX )
1336 $ LDA = LDA + 1
1337 * Skip tests if not enough room.
1338 IF( LDA.GT.NMAX )
1339 $ GO TO 80
1340 LAA = LDA*NA
1341 *
1342 * Generate the matrix A.
1343 *
1344 CALL ZMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
1345 $ RESET, ZERO )
1346 *
1347 DO 70 ICU = 1, 2
1348 UPLO = ICHU( ICU: ICU )
1349 UPPER = UPLO.EQ.'U'
1350 *
1351 DO 60 IA = 1, NALF
1352 ALPHA = ALF( IA )
1353 IF( CONJ )THEN
1354 RALPHA = DBLE( ALPHA )
1355 ALPHA = DCMPLX( RALPHA, RZERO )
1356 END IF
1357 *
1358 DO 50 IB = 1, NBET
1359 BETA = BET( IB )
1360 IF( CONJ )THEN
1361 RBETA = DBLE( BETA )
1362 BETA = DCMPLX( RBETA, RZERO )
1363 END IF
1364 NULL = N.LE.0
1365 IF( CONJ )
1366 $ NULL = NULL.OR.( ( K.LE.0.OR.RALPHA.EQ.
1367 $ RZERO ).AND.RBETA.EQ.RONE )
1368 *
1369 * Generate the matrix C.
1370 *
1371 CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C,
1372 $ NMAX, CC, LDC, RESET, ZERO )
1373 *
1374 NC = NC + 1
1375 *
1376 * Save every datum before calling the subroutine.
1377 *
1378 UPLOS = UPLO
1379 TRANSS = TRANS
1380 NS = N
1381 KS = K
1382 IF( CONJ )THEN
1383 RALS = RALPHA
1384 ELSE
1385 ALS = ALPHA
1386 END IF
1387 DO 10 I = 1, LAA
1388 AS( I ) = AA( I )
1389 10 CONTINUE
1390 LDAS = LDA
1391 IF( CONJ )THEN
1392 RBETS = RBETA
1393 ELSE
1394 BETS = BETA
1395 END IF
1396 DO 20 I = 1, LCC
1397 CS( I ) = CC( I )
1398 20 CONTINUE
1399 LDCS = LDC
1400 *
1401 * Call the subroutine.
1402 *
1403 IF( CONJ )THEN
1404 IF( TRACE )
1405 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
1406 $ TRANS, N, K, RALPHA, LDA, RBETA, LDC
1407 IF( REWI )
1408 $ REWIND NTRA
1409 CALL ZHERK( UPLO, TRANS, N, K, RALPHA, AA,
1410 $ LDA, RBETA, CC, LDC )
1411 ELSE
1412 IF( TRACE )
1413 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO,
1414 $ TRANS, N, K, ALPHA, LDA, BETA, LDC
1415 IF( REWI )
1416 $ REWIND NTRA
1417 CALL ZSYRK( UPLO, TRANS, N, K, ALPHA, AA,
1418 $ LDA, BETA, CC, LDC )
1419 END IF
1420 *
1421 * Check if error-exit was taken incorrectly.
1422 *
1423 IF( .NOT.OK )THEN
1424 WRITE( NOUT, FMT = 9992 )
1425 FATAL = .TRUE.
1426 GO TO 120
1427 END IF
1428 *
1429 * See what data changed inside subroutines.
1430 *
1431 ISAME( 1 ) = UPLOS.EQ.UPLO
1432 ISAME( 2 ) = TRANSS.EQ.TRANS
1433 ISAME( 3 ) = NS.EQ.N
1434 ISAME( 4 ) = KS.EQ.K
1435 IF( CONJ )THEN
1436 ISAME( 5 ) = RALS.EQ.RALPHA
1437 ELSE
1438 ISAME( 5 ) = ALS.EQ.ALPHA
1439 END IF
1440 ISAME( 6 ) = LZE( AS, AA, LAA )
1441 ISAME( 7 ) = LDAS.EQ.LDA
1442 IF( CONJ )THEN
1443 ISAME( 8 ) = RBETS.EQ.RBETA
1444 ELSE
1445 ISAME( 8 ) = BETS.EQ.BETA
1446 END IF
1447 IF( NULL )THEN
1448 ISAME( 9 ) = LZE( CS, CC, LCC )
1449 ELSE
1450 ISAME( 9 ) = LZERES( SNAME( 2: 3 ), UPLO, N,
1451 $ N, CS, CC, LDC )
1452 END IF
1453 ISAME( 10 ) = LDCS.EQ.LDC
1454 *
1455 * If data was incorrectly changed, report and
1456 * return.
1457 *
1458 SAME = .TRUE.
1459 DO 30 I = 1, NARGS
1460 SAME = SAME.AND.ISAME( I )
1461 IF( .NOT.ISAME( I ) )
1462 $ WRITE( NOUT, FMT = 9998 )I
1463 30 CONTINUE
1464 IF( .NOT.SAME )THEN
1465 FATAL = .TRUE.
1466 GO TO 120
1467 END IF
1468 *
1469 IF( .NOT.NULL )THEN
1470 *
1471 * Check the result column by column.
1472 *
1473 IF( CONJ )THEN
1474 TRANST = 'C'
1475 ELSE
1476 TRANST = 'T'
1477 END IF
1478 JC = 1
1479 DO 40 J = 1, N
1480 IF( UPPER )THEN
1481 JJ = 1
1482 LJ = J
1483 ELSE
1484 JJ = J
1485 LJ = N - J + 1
1486 END IF
1487 IF( TRAN )THEN
1488 CALL ZMMCH( TRANST, 'N', LJ, 1, K,
1489 $ ALPHA, A( 1, JJ ), NMAX,
1490 $ A( 1, J ), NMAX, BETA,
1491 $ C( JJ, J ), NMAX, CT, G,
1492 $ CC( JC ), LDC, EPS, ERR,
1493 $ FATAL, NOUT, .TRUE. )
1494 ELSE
1495 CALL ZMMCH( 'N', TRANST, LJ, 1, K,
1496 $ ALPHA, A( JJ, 1 ), NMAX,
1497 $ A( J, 1 ), NMAX, BETA,
1498 $ C( JJ, J ), NMAX, CT, G,
1499 $ CC( JC ), LDC, EPS, ERR,
1500 $ FATAL, NOUT, .TRUE. )
1501 END IF
1502 IF( UPPER )THEN
1503 JC = JC + LDC
1504 ELSE
1505 JC = JC + LDC + 1
1506 END IF
1507 ERRMAX = MAX( ERRMAX, ERR )
1508 * If got really bad answer, report and
1509 * return.
1510 IF( FATAL )
1511 $ GO TO 110
1512 40 CONTINUE
1513 END IF
1514 *
1515 50 CONTINUE
1516 *
1517 60 CONTINUE
1518 *
1519 70 CONTINUE
1520 *
1521 80 CONTINUE
1522 *
1523 90 CONTINUE
1524 *
1525 100 CONTINUE
1526 *
1527 * Report result.
1528 *
1529 IF( ERRMAX.LT.THRESH )THEN
1530 WRITE( NOUT, FMT = 9999 )SNAME, NC
1531 ELSE
1532 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1533 END IF
1534 GO TO 130
1535 *
1536 110 CONTINUE
1537 IF( N.GT.1 )
1538 $ WRITE( NOUT, FMT = 9995 )J
1539 *
1540 120 CONTINUE
1541 WRITE( NOUT, FMT = 9996 )SNAME
1542 IF( CONJ )THEN
1543 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, RALPHA,
1544 $ LDA, RBETA, LDC
1545 ELSE
1546 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
1547 $ LDA, BETA, LDC
1548 END IF
1549 *
1550 130 CONTINUE
1551 RETURN
1552 *
1553 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1554 $ 'S)' )
1555 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1556 $ 'ANGED INCORRECTLY *******' )
1557 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1558 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1559 $ ' - SUSPECT *******' )
1560 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1561 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1562 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1563 $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ',
1564 $ ' .' )
1565 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1566 $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1,
1567 $ '), C,', I3, ') .' )
1568 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1569 $ '******' )
1570 *
1571 * End of ZCHK4.
1572 *
1573 END
1574 SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1575 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1576 $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
1577 *
1578 * Tests ZHER2K and ZSYR2K.
1579 *
1580 * Auxiliary routine for test program for Level 3 Blas.
1581 *
1582 * -- Written on 8-February-1989.
1583 * Jack Dongarra, Argonne National Laboratory.
1584 * Iain Duff, AERE Harwell.
1585 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1586 * Sven Hammarling, Numerical Algorithms Group Ltd.
1587 *
1588 * .. Parameters ..
1589 COMPLEX*16 ZERO, ONE
1590 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ),
1591 $ ONE = ( 1.0D0, 0.0D0 ) )
1592 DOUBLE PRECISION RONE, RZERO
1593 PARAMETER ( RONE = 1.0D0, RZERO = 0.0D0 )
1594 * .. Scalar Arguments ..
1595 DOUBLE PRECISION EPS, THRESH
1596 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1597 LOGICAL FATAL, REWI, TRACE
1598 CHARACTER*6 SNAME
1599 * .. Array Arguments ..
1600 COMPLEX*16 AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1601 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1602 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1603 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1604 $ W( 2*NMAX )
1605 DOUBLE PRECISION G( NMAX )
1606 INTEGER IDIM( NIDIM )
1607 * .. Local Scalars ..
1608 COMPLEX*16 ALPHA, ALS, BETA, BETS
1609 DOUBLE PRECISION ERR, ERRMAX, RBETA, RBETS
1610 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1611 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1612 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1613 LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER
1614 CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS
1615 CHARACTER*2 ICHT, ICHU
1616 * .. Local Arrays ..
1617 LOGICAL ISAME( 13 )
1618 * .. External Functions ..
1619 LOGICAL LZE, LZERES
1620 EXTERNAL LZE, LZERES
1621 * .. External Subroutines ..
1622 EXTERNAL ZHER2K, ZMAKE, ZMMCH, ZSYR2K
1623 * .. Intrinsic Functions ..
1624 INTRINSIC DCMPLX, DCONJG, MAX, DBLE
1625 * .. Scalars in Common ..
1626 INTEGER INFOT, NOUTC
1627 LOGICAL LERR, OK
1628 * .. Common blocks ..
1629 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1630 * .. Data statements ..
1631 DATA ICHT/'NC'/, ICHU/'UL'/
1632 * .. Executable Statements ..
1633 CONJ = SNAME( 2: 3 ).EQ.'HE'
1634 *
1635 NARGS = 12
1636 NC = 0
1637 RESET = .TRUE.
1638 ERRMAX = RZERO
1639 *
1640 DO 130 IN = 1, NIDIM
1641 N = IDIM( IN )
1642 * Set LDC to 1 more than minimum value if room.
1643 LDC = N
1644 IF( LDC.LT.NMAX )
1645 $ LDC = LDC + 1
1646 * Skip tests if not enough room.
1647 IF( LDC.GT.NMAX )
1648 $ GO TO 130
1649 LCC = LDC*N
1650 *
1651 DO 120 IK = 1, NIDIM
1652 K = IDIM( IK )
1653 *
1654 DO 110 ICT = 1, 2
1655 TRANS = ICHT( ICT: ICT )
1656 TRAN = TRANS.EQ.'C'
1657 IF( TRAN.AND..NOT.CONJ )
1658 $ TRANS = 'T'
1659 IF( TRAN )THEN
1660 MA = K
1661 NA = N
1662 ELSE
1663 MA = N
1664 NA = K
1665 END IF
1666 * Set LDA to 1 more than minimum value if room.
1667 LDA = MA
1668 IF( LDA.LT.NMAX )
1669 $ LDA = LDA + 1
1670 * Skip tests if not enough room.
1671 IF( LDA.GT.NMAX )
1672 $ GO TO 110
1673 LAA = LDA*NA
1674 *
1675 * Generate the matrix A.
1676 *
1677 IF( TRAN )THEN
1678 CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA,
1679 $ LDA, RESET, ZERO )
1680 ELSE
1681 CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA,
1682 $ RESET, ZERO )
1683 END IF
1684 *
1685 * Generate the matrix B.
1686 *
1687 LDB = LDA
1688 LBB = LAA
1689 IF( TRAN )THEN
1690 CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ),
1691 $ 2*NMAX, BB, LDB, RESET, ZERO )
1692 ELSE
1693 CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ),
1694 $ NMAX, BB, LDB, RESET, ZERO )
1695 END IF
1696 *
1697 DO 100 ICU = 1, 2
1698 UPLO = ICHU( ICU: ICU )
1699 UPPER = UPLO.EQ.'U'
1700 *
1701 DO 90 IA = 1, NALF
1702 ALPHA = ALF( IA )
1703 *
1704 DO 80 IB = 1, NBET
1705 BETA = BET( IB )
1706 IF( CONJ )THEN
1707 RBETA = DBLE( BETA )
1708 BETA = DCMPLX( RBETA, RZERO )
1709 END IF
1710 NULL = N.LE.0
1711 IF( CONJ )
1712 $ NULL = NULL.OR.( ( K.LE.0.OR.ALPHA.EQ.
1713 $ ZERO ).AND.RBETA.EQ.RONE )
1714 *
1715 * Generate the matrix C.
1716 *
1717 CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C,
1718 $ NMAX, CC, LDC, RESET, ZERO )
1719 *
1720 NC = NC + 1
1721 *
1722 * Save every datum before calling the subroutine.
1723 *
1724 UPLOS = UPLO
1725 TRANSS = TRANS
1726 NS = N
1727 KS = K
1728 ALS = ALPHA
1729 DO 10 I = 1, LAA
1730 AS( I ) = AA( I )
1731 10 CONTINUE
1732 LDAS = LDA
1733 DO 20 I = 1, LBB
1734 BS( I ) = BB( I )
1735 20 CONTINUE
1736 LDBS = LDB
1737 IF( CONJ )THEN
1738 RBETS = RBETA
1739 ELSE
1740 BETS = BETA
1741 END IF
1742 DO 30 I = 1, LCC
1743 CS( I ) = CC( I )
1744 30 CONTINUE
1745 LDCS = LDC
1746 *
1747 * Call the subroutine.
1748 *
1749 IF( CONJ )THEN
1750 IF( TRACE )
1751 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
1752 $ TRANS, N, K, ALPHA, LDA, LDB, RBETA, LDC
1753 IF( REWI )
1754 $ REWIND NTRA
1755 CALL ZHER2K( UPLO, TRANS, N, K, ALPHA, AA,
1756 $ LDA, BB, LDB, RBETA, CC, LDC )
1757 ELSE
1758 IF( TRACE )
1759 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO,
1760 $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC
1761 IF( REWI )
1762 $ REWIND NTRA
1763 CALL ZSYR2K( UPLO, TRANS, N, K, ALPHA, AA,
1764 $ LDA, BB, LDB, BETA, CC, LDC )
1765 END IF
1766 *
1767 * Check if error-exit was taken incorrectly.
1768 *
1769 IF( .NOT.OK )THEN
1770 WRITE( NOUT, FMT = 9992 )
1771 FATAL = .TRUE.
1772 GO TO 150
1773 END IF
1774 *
1775 * See what data changed inside subroutines.
1776 *
1777 ISAME( 1 ) = UPLOS.EQ.UPLO
1778 ISAME( 2 ) = TRANSS.EQ.TRANS
1779 ISAME( 3 ) = NS.EQ.N
1780 ISAME( 4 ) = KS.EQ.K
1781 ISAME( 5 ) = ALS.EQ.ALPHA
1782 ISAME( 6 ) = LZE( AS, AA, LAA )
1783 ISAME( 7 ) = LDAS.EQ.LDA
1784 ISAME( 8 ) = LZE( BS, BB, LBB )
1785 ISAME( 9 ) = LDBS.EQ.LDB
1786 IF( CONJ )THEN
1787 ISAME( 10 ) = RBETS.EQ.RBETA
1788 ELSE
1789 ISAME( 10 ) = BETS.EQ.BETA
1790 END IF
1791 IF( NULL )THEN
1792 ISAME( 11 ) = LZE( CS, CC, LCC )
1793 ELSE
1794 ISAME( 11 ) = LZERES( 'HE', UPLO, N, N, CS,
1795 $ CC, LDC )
1796 END IF
1797 ISAME( 12 ) = LDCS.EQ.LDC
1798 *
1799 * If data was incorrectly changed, report and
1800 * return.
1801 *
1802 SAME = .TRUE.
1803 DO 40 I = 1, NARGS
1804 SAME = SAME.AND.ISAME( I )
1805 IF( .NOT.ISAME( I ) )
1806 $ WRITE( NOUT, FMT = 9998 )I
1807 40 CONTINUE
1808 IF( .NOT.SAME )THEN
1809 FATAL = .TRUE.
1810 GO TO 150
1811 END IF
1812 *
1813 IF( .NOT.NULL )THEN
1814 *
1815 * Check the result column by column.
1816 *
1817 IF( CONJ )THEN
1818 TRANST = 'C'
1819 ELSE
1820 TRANST = 'T'
1821 END IF
1822 JJAB = 1
1823 JC = 1
1824 DO 70 J = 1, N
1825 IF( UPPER )THEN
1826 JJ = 1
1827 LJ = J
1828 ELSE
1829 JJ = J
1830 LJ = N - J + 1
1831 END IF
1832 IF( TRAN )THEN
1833 DO 50 I = 1, K
1834 W( I ) = ALPHA*AB( ( J - 1 )*2*
1835 $ NMAX + K + I )
1836 IF( CONJ )THEN
1837 W( K + I ) = DCONJG( ALPHA )*
1838 $ AB( ( J - 1 )*2*
1839 $ NMAX + I )
1840 ELSE
1841 W( K + I ) = ALPHA*
1842 $ AB( ( J - 1 )*2*
1843 $ NMAX + I )
1844 END IF
1845 50 CONTINUE
1846 CALL ZMMCH( TRANST, 'N', LJ, 1, 2*K,
1847 $ ONE, AB( JJAB ), 2*NMAX, W,
1848 $ 2*NMAX, BETA, C( JJ, J ),
1849 $ NMAX, CT, G, CC( JC ), LDC,
1850 $ EPS, ERR, FATAL, NOUT,
1851 $ .TRUE. )
1852 ELSE
1853 DO 60 I = 1, K
1854 IF( CONJ )THEN
1855 W( I ) = ALPHA*DCONJG( AB( ( K +
1856 $ I - 1 )*NMAX + J ) )
1857 W( K + I ) = DCONJG( ALPHA*
1858 $ AB( ( I - 1 )*NMAX +
1859 $ J ) )
1860 ELSE
1861 W( I ) = ALPHA*AB( ( K + I - 1 )*
1862 $ NMAX + J )
1863 W( K + I ) = ALPHA*
1864 $ AB( ( I - 1 )*NMAX +
1865 $ J )
1866 END IF
1867 60 CONTINUE
1868 CALL ZMMCH( 'N', 'N', LJ, 1, 2*K, ONE,
1869 $ AB( JJ ), NMAX, W, 2*NMAX,
1870 $ BETA, C( JJ, J ), NMAX, CT,
1871 $ G, CC( JC ), LDC, EPS, ERR,
1872 $ FATAL, NOUT, .TRUE. )
1873 END IF
1874 IF( UPPER )THEN
1875 JC = JC + LDC
1876 ELSE
1877 JC = JC + LDC + 1
1878 IF( TRAN )
1879 $ JJAB = JJAB + 2*NMAX
1880 END IF
1881 ERRMAX = MAX( ERRMAX, ERR )
1882 * If got really bad answer, report and
1883 * return.
1884 IF( FATAL )
1885 $ GO TO 140
1886 70 CONTINUE
1887 END IF
1888 *
1889 80 CONTINUE
1890 *
1891 90 CONTINUE
1892 *
1893 100 CONTINUE
1894 *
1895 110 CONTINUE
1896 *
1897 120 CONTINUE
1898 *
1899 130 CONTINUE
1900 *
1901 * Report result.
1902 *
1903 IF( ERRMAX.LT.THRESH )THEN
1904 WRITE( NOUT, FMT = 9999 )SNAME, NC
1905 ELSE
1906 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1907 END IF
1908 GO TO 160
1909 *
1910 140 CONTINUE
1911 IF( N.GT.1 )
1912 $ WRITE( NOUT, FMT = 9995 )J
1913 *
1914 150 CONTINUE
1915 WRITE( NOUT, FMT = 9996 )SNAME
1916 IF( CONJ )THEN
1917 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
1918 $ LDA, LDB, RBETA, LDC
1919 ELSE
1920 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
1921 $ LDA, LDB, BETA, LDC
1922 END IF
1923 *
1924 160 CONTINUE
1925 RETURN
1926 *
1927 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1928 $ 'S)' )
1929 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1930 $ 'ANGED INCORRECTLY *******' )
1931 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1932 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1933 $ ' - SUSPECT *******' )
1934 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1935 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1936 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1937 $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1,
1938 $ ', C,', I3, ') .' )
1939 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1940 $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
1941 $ ',', F4.1, '), C,', I3, ') .' )
1942 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1943 $ '******' )
1944 *
1945 * End of ZCHK5.
1946 *
1947 END
1948 SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT )
1949 *
1950 * Tests the error exits from the Level 3 Blas.
1951 * Requires a special version of the error-handling routine XERBLA.
1952 * ALPHA, RALPHA, BETA, RBETA, A, B and C should not need to be defined.
1953 *
1954 * Auxiliary routine for test program for Level 3 Blas.
1955 *
1956 * -- Written on 8-February-1989.
1957 * Jack Dongarra, Argonne National Laboratory.
1958 * Iain Duff, AERE Harwell.
1959 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1960 * Sven Hammarling, Numerical Algorithms Group Ltd.
1961 *
1962 * .. Scalar Arguments ..
1963 INTEGER ISNUM, NOUT
1964 CHARACTER*6 SRNAMT
1965 * .. Scalars in Common ..
1966 INTEGER INFOT, NOUTC
1967 LOGICAL LERR, OK
1968 * .. Local Scalars ..
1969 COMPLEX*16 ALPHA, BETA
1970 DOUBLE PRECISION RALPHA, RBETA
1971 * .. Local Arrays ..
1972 COMPLEX*16 A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
1973 * .. External Subroutines ..
1974 EXTERNAL ZGEMM, ZHEMM, ZHER2K, ZHERK, CHKXER, ZSYMM,
1975 $ ZSYR2K, ZSYRK, ZTRMM, ZTRSM
1976 * .. Common blocks ..
1977 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1978 * .. Executable Statements ..
1979 * OK is set to .FALSE. by the special version of XERBLA or by CHKXER
1980 * if anything is wrong.
1981 OK = .TRUE.
1982 * LERR is set to .TRUE. by the special version of XERBLA each time
1983 * it is called, and is then tested and re-set by CHKXER.
1984 LERR = .FALSE.
1985 GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
1986 $ 90 )ISNUM
1987 10 INFOT = 1
1988 CALL ZGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1989 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1990 INFOT = 1
1991 CALL ZGEMM( '/', 'C', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1992 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1993 INFOT = 1
1994 CALL ZGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1995 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1996 INFOT = 2
1997 CALL ZGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1998 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1999 INFOT = 2
2000 CALL ZGEMM( 'C', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2001 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2002 INFOT = 2
2003 CALL ZGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2004 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2005 INFOT = 3
2006 CALL ZGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2007 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2008 INFOT = 3
2009 CALL ZGEMM( 'N', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2010 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2011 INFOT = 3
2012 CALL ZGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2013 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2014 INFOT = 3
2015 CALL ZGEMM( 'C', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2016 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2017 INFOT = 3
2018 CALL ZGEMM( 'C', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2019 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2020 INFOT = 3
2021 CALL ZGEMM( 'C', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2022 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2023 INFOT = 3
2024 CALL ZGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2025 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2026 INFOT = 3
2027 CALL ZGEMM( 'T', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2028 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2029 INFOT = 3
2030 CALL ZGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2031 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2032 INFOT = 4
2033 CALL ZGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2034 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2035 INFOT = 4
2036 CALL ZGEMM( 'N', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2037 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2038 INFOT = 4
2039 CALL ZGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2040 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2041 INFOT = 4
2042 CALL ZGEMM( 'C', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2043 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2044 INFOT = 4
2045 CALL ZGEMM( 'C', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2046 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2047 INFOT = 4
2048 CALL ZGEMM( 'C', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2049 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2050 INFOT = 4
2051 CALL ZGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2052 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2053 INFOT = 4
2054 CALL ZGEMM( 'T', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2055 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2056 INFOT = 4
2057 CALL ZGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2058 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2059 INFOT = 5
2060 CALL ZGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2061 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2062 INFOT = 5
2063 CALL ZGEMM( 'N', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2064 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2065 INFOT = 5
2066 CALL ZGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2067 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2068 INFOT = 5
2069 CALL ZGEMM( 'C', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2070 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2071 INFOT = 5
2072 CALL ZGEMM( 'C', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2073 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2074 INFOT = 5
2075 CALL ZGEMM( 'C', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2076 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2077 INFOT = 5
2078 CALL ZGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2079 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2080 INFOT = 5
2081 CALL ZGEMM( 'T', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2082 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2083 INFOT = 5
2084 CALL ZGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2085 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2086 INFOT = 8
2087 CALL ZGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2088 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2089 INFOT = 8
2090 CALL ZGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2091 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2092 INFOT = 8
2093 CALL ZGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2094 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2095 INFOT = 8
2096 CALL ZGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
2097 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2098 INFOT = 8
2099 CALL ZGEMM( 'C', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2100 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2101 INFOT = 8
2102 CALL ZGEMM( 'C', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2103 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2104 INFOT = 8
2105 CALL ZGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
2106 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2107 INFOT = 8
2108 CALL ZGEMM( 'T', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2109 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2110 INFOT = 8
2111 CALL ZGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2112 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2113 INFOT = 10
2114 CALL ZGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2115 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2116 INFOT = 10
2117 CALL ZGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
2118 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2119 INFOT = 10
2120 CALL ZGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
2121 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2122 INFOT = 10
2123 CALL ZGEMM( 'N', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2124 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2125 INFOT = 10
2126 CALL ZGEMM( 'C', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2127 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2128 INFOT = 10
2129 CALL ZGEMM( 'T', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2130 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2131 INFOT = 10
2132 CALL ZGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2133 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2134 INFOT = 10
2135 CALL ZGEMM( 'C', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2136 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2137 INFOT = 10
2138 CALL ZGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2139 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2140 INFOT = 13
2141 CALL ZGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2142 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2143 INFOT = 13
2144 CALL ZGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2145 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2146 INFOT = 13
2147 CALL ZGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2148 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2149 INFOT = 13
2150 CALL ZGEMM( 'C', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2151 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2152 INFOT = 13
2153 CALL ZGEMM( 'C', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2154 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2155 INFOT = 13
2156 CALL ZGEMM( 'C', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2157 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2158 INFOT = 13
2159 CALL ZGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2160 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2161 INFOT = 13
2162 CALL ZGEMM( 'T', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2163 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2164 INFOT = 13
2165 CALL ZGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2166 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2167 GO TO 100
2168 20 INFOT = 1
2169 CALL ZHEMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2170 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2171 INFOT = 2
2172 CALL ZHEMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2173 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2174 INFOT = 3
2175 CALL ZHEMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2176 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2177 INFOT = 3
2178 CALL ZHEMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2179 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2180 INFOT = 3
2181 CALL ZHEMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2182 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2183 INFOT = 3
2184 CALL ZHEMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2185 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2186 INFOT = 4
2187 CALL ZHEMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2188 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2189 INFOT = 4
2190 CALL ZHEMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2191 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2192 INFOT = 4
2193 CALL ZHEMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2194 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2195 INFOT = 4
2196 CALL ZHEMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2197 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2198 INFOT = 7
2199 CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
2200 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2201 INFOT = 7
2202 CALL ZHEMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2203 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2204 INFOT = 7
2205 CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
2206 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2207 INFOT = 7
2208 CALL ZHEMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2209 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2210 INFOT = 9
2211 CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2212 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2213 INFOT = 9
2214 CALL ZHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2215 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2216 INFOT = 9
2217 CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2218 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2219 INFOT = 9
2220 CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2221 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2222 INFOT = 12
2223 CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2224 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2225 INFOT = 12
2226 CALL ZHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
2227 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2228 INFOT = 12
2229 CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2230 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2231 INFOT = 12
2232 CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
2233 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2234 GO TO 100
2235 30 INFOT = 1
2236 CALL ZSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2237 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2238 INFOT = 2
2239 CALL ZSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2240 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2241 INFOT = 3
2242 CALL ZSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2243 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2244 INFOT = 3
2245 CALL ZSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2246 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2247 INFOT = 3
2248 CALL ZSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2249 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2250 INFOT = 3
2251 CALL ZSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2252 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2253 INFOT = 4
2254 CALL ZSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2255 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2256 INFOT = 4
2257 CALL ZSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2258 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2259 INFOT = 4
2260 CALL ZSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2261 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2262 INFOT = 4
2263 CALL ZSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2264 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2265 INFOT = 7
2266 CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
2267 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2268 INFOT = 7
2269 CALL ZSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2270 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2271 INFOT = 7
2272 CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
2273 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2274 INFOT = 7
2275 CALL ZSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2276 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2277 INFOT = 9
2278 CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2279 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2280 INFOT = 9
2281 CALL ZSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2282 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2283 INFOT = 9
2284 CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
2285 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2286 INFOT = 9
2287 CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2288 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2289 INFOT = 12
2290 CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2291 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2292 INFOT = 12
2293 CALL ZSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
2294 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2295 INFOT = 12
2296 CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2297 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2298 INFOT = 12
2299 CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
2300 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2301 GO TO 100
2302 40 INFOT = 1
2303 CALL ZTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2304 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2305 INFOT = 2
2306 CALL ZTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2307 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2308 INFOT = 3
2309 CALL ZTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2310 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2311 INFOT = 4
2312 CALL ZTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
2313 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2314 INFOT = 5
2315 CALL ZTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2316 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2317 INFOT = 5
2318 CALL ZTRMM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2319 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2320 INFOT = 5
2321 CALL ZTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2322 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2323 INFOT = 5
2324 CALL ZTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2325 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2326 INFOT = 5
2327 CALL ZTRMM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2328 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2329 INFOT = 5
2330 CALL ZTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2331 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2332 INFOT = 5
2333 CALL ZTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2334 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2335 INFOT = 5
2336 CALL ZTRMM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2337 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2338 INFOT = 5
2339 CALL ZTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2340 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2341 INFOT = 5
2342 CALL ZTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2343 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2344 INFOT = 5
2345 CALL ZTRMM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2346 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2347 INFOT = 5
2348 CALL ZTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2349 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2350 INFOT = 6
2351 CALL ZTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2352 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2353 INFOT = 6
2354 CALL ZTRMM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2355 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2356 INFOT = 6
2357 CALL ZTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2358 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2359 INFOT = 6
2360 CALL ZTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2361 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2362 INFOT = 6
2363 CALL ZTRMM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2364 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2365 INFOT = 6
2366 CALL ZTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2367 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2368 INFOT = 6
2369 CALL ZTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2370 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2371 INFOT = 6
2372 CALL ZTRMM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2373 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2374 INFOT = 6
2375 CALL ZTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2376 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2377 INFOT = 6
2378 CALL ZTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2379 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2380 INFOT = 6
2381 CALL ZTRMM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2382 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2383 INFOT = 6
2384 CALL ZTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2385 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2386 INFOT = 9
2387 CALL ZTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2388 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2389 INFOT = 9
2390 CALL ZTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2391 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2392 INFOT = 9
2393 CALL ZTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2394 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2395 INFOT = 9
2396 CALL ZTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2397 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2398 INFOT = 9
2399 CALL ZTRMM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2400 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2401 INFOT = 9
2402 CALL ZTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2403 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2404 INFOT = 9
2405 CALL ZTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2406 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2407 INFOT = 9
2408 CALL ZTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2409 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2410 INFOT = 9
2411 CALL ZTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2412 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2413 INFOT = 9
2414 CALL ZTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2415 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2416 INFOT = 9
2417 CALL ZTRMM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2418 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2419 INFOT = 9
2420 CALL ZTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2421 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2422 INFOT = 11
2423 CALL ZTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2424 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2425 INFOT = 11
2426 CALL ZTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2427 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2428 INFOT = 11
2429 CALL ZTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2430 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2431 INFOT = 11
2432 CALL ZTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2433 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2434 INFOT = 11
2435 CALL ZTRMM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2436 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2437 INFOT = 11
2438 CALL ZTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2439 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2440 INFOT = 11
2441 CALL ZTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2442 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2443 INFOT = 11
2444 CALL ZTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2445 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2446 INFOT = 11
2447 CALL ZTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2448 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2449 INFOT = 11
2450 CALL ZTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2451 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2452 INFOT = 11
2453 CALL ZTRMM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2454 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2455 INFOT = 11
2456 CALL ZTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2457 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2458 GO TO 100
2459 50 INFOT = 1
2460 CALL ZTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2461 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2462 INFOT = 2
2463 CALL ZTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2464 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2465 INFOT = 3
2466 CALL ZTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2467 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2468 INFOT = 4
2469 CALL ZTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
2470 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2471 INFOT = 5
2472 CALL ZTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2473 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2474 INFOT = 5
2475 CALL ZTRSM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2476 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2477 INFOT = 5
2478 CALL ZTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2479 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2480 INFOT = 5
2481 CALL ZTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2482 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2483 INFOT = 5
2484 CALL ZTRSM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2485 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2486 INFOT = 5
2487 CALL ZTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2488 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2489 INFOT = 5
2490 CALL ZTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2491 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2492 INFOT = 5
2493 CALL ZTRSM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2494 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2495 INFOT = 5
2496 CALL ZTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2497 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2498 INFOT = 5
2499 CALL ZTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2500 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2501 INFOT = 5
2502 CALL ZTRSM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2503 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2504 INFOT = 5
2505 CALL ZTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2506 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2507 INFOT = 6
2508 CALL ZTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2509 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2510 INFOT = 6
2511 CALL ZTRSM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2512 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2513 INFOT = 6
2514 CALL ZTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2515 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2516 INFOT = 6
2517 CALL ZTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2518 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2519 INFOT = 6
2520 CALL ZTRSM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2521 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2522 INFOT = 6
2523 CALL ZTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2524 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2525 INFOT = 6
2526 CALL ZTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2527 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2528 INFOT = 6
2529 CALL ZTRSM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2530 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2531 INFOT = 6
2532 CALL ZTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2533 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2534 INFOT = 6
2535 CALL ZTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2536 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2537 INFOT = 6
2538 CALL ZTRSM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2539 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2540 INFOT = 6
2541 CALL ZTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2542 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2543 INFOT = 9
2544 CALL ZTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2545 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2546 INFOT = 9
2547 CALL ZTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2548 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2549 INFOT = 9
2550 CALL ZTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2551 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2552 INFOT = 9
2553 CALL ZTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2554 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2555 INFOT = 9
2556 CALL ZTRSM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2557 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2558 INFOT = 9
2559 CALL ZTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2560 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2561 INFOT = 9
2562 CALL ZTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2563 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2564 INFOT = 9
2565 CALL ZTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2566 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2567 INFOT = 9
2568 CALL ZTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2569 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2570 INFOT = 9
2571 CALL ZTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2572 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2573 INFOT = 9
2574 CALL ZTRSM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2575 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2576 INFOT = 9
2577 CALL ZTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2578 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2579 INFOT = 11
2580 CALL ZTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2581 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2582 INFOT = 11
2583 CALL ZTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2584 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2585 INFOT = 11
2586 CALL ZTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2587 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2588 INFOT = 11
2589 CALL ZTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2590 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2591 INFOT = 11
2592 CALL ZTRSM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2593 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2594 INFOT = 11
2595 CALL ZTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2596 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2597 INFOT = 11
2598 CALL ZTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2599 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2600 INFOT = 11
2601 CALL ZTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2602 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2603 INFOT = 11
2604 CALL ZTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2605 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2606 INFOT = 11
2607 CALL ZTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2608 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2609 INFOT = 11
2610 CALL ZTRSM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2611 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2612 INFOT = 11
2613 CALL ZTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2614 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2615 GO TO 100
2616 60 INFOT = 1
2617 CALL ZHERK( '/', 'N', 0, 0, RALPHA, A, 1, RBETA, C, 1 )
2618 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2619 INFOT = 2
2620 CALL ZHERK( 'U', 'T', 0, 0, RALPHA, A, 1, RBETA, C, 1 )
2621 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2622 INFOT = 3
2623 CALL ZHERK( 'U', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 )
2624 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2625 INFOT = 3
2626 CALL ZHERK( 'U', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 )
2627 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2628 INFOT = 3
2629 CALL ZHERK( 'L', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 )
2630 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2631 INFOT = 3
2632 CALL ZHERK( 'L', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 )
2633 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2634 INFOT = 4
2635 CALL ZHERK( 'U', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 )
2636 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2637 INFOT = 4
2638 CALL ZHERK( 'U', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 )
2639 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2640 INFOT = 4
2641 CALL ZHERK( 'L', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 )
2642 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2643 INFOT = 4
2644 CALL ZHERK( 'L', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 )
2645 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2646 INFOT = 7
2647 CALL ZHERK( 'U', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 )
2648 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2649 INFOT = 7
2650 CALL ZHERK( 'U', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 )
2651 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2652 INFOT = 7
2653 CALL ZHERK( 'L', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 )
2654 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2655 INFOT = 7
2656 CALL ZHERK( 'L', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 )
2657 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2658 INFOT = 10
2659 CALL ZHERK( 'U', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 )
2660 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2661 INFOT = 10
2662 CALL ZHERK( 'U', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 )
2663 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2664 INFOT = 10
2665 CALL ZHERK( 'L', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 )
2666 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2667 INFOT = 10
2668 CALL ZHERK( 'L', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 )
2669 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2670 GO TO 100
2671 70 INFOT = 1
2672 CALL ZSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 )
2673 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2674 INFOT = 2
2675 CALL ZSYRK( 'U', 'C', 0, 0, ALPHA, A, 1, BETA, C, 1 )
2676 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2677 INFOT = 3
2678 CALL ZSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2679 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2680 INFOT = 3
2681 CALL ZSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2682 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2683 INFOT = 3
2684 CALL ZSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2685 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2686 INFOT = 3
2687 CALL ZSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2688 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2689 INFOT = 4
2690 CALL ZSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2691 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2692 INFOT = 4
2693 CALL ZSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2694 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2695 INFOT = 4
2696 CALL ZSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2697 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2698 INFOT = 4
2699 CALL ZSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2700 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2701 INFOT = 7
2702 CALL ZSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
2703 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2704 INFOT = 7
2705 CALL ZSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
2706 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2707 INFOT = 7
2708 CALL ZSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
2709 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2710 INFOT = 7
2711 CALL ZSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
2712 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2713 INFOT = 10
2714 CALL ZSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
2715 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2716 INFOT = 10
2717 CALL ZSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
2718 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2719 INFOT = 10
2720 CALL ZSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
2721 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2722 INFOT = 10
2723 CALL ZSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
2724 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2725 GO TO 100
2726 80 INFOT = 1
2727 CALL ZHER2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2728 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2729 INFOT = 2
2730 CALL ZHER2K( 'U', 'T', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2731 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2732 INFOT = 3
2733 CALL ZHER2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2734 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2735 INFOT = 3
2736 CALL ZHER2K( 'U', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2737 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2738 INFOT = 3
2739 CALL ZHER2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2740 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2741 INFOT = 3
2742 CALL ZHER2K( 'L', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2743 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2744 INFOT = 4
2745 CALL ZHER2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2746 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2747 INFOT = 4
2748 CALL ZHER2K( 'U', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2749 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2750 INFOT = 4
2751 CALL ZHER2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2752 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2753 INFOT = 4
2754 CALL ZHER2K( 'L', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2755 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2756 INFOT = 7
2757 CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 )
2758 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2759 INFOT = 7
2760 CALL ZHER2K( 'U', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2761 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2762 INFOT = 7
2763 CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 )
2764 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2765 INFOT = 7
2766 CALL ZHER2K( 'L', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2767 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2768 INFOT = 9
2769 CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 )
2770 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2771 INFOT = 9
2772 CALL ZHER2K( 'U', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 )
2773 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2774 INFOT = 9
2775 CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 )
2776 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2777 INFOT = 9
2778 CALL ZHER2K( 'L', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 )
2779 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2780 INFOT = 12
2781 CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 )
2782 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2783 INFOT = 12
2784 CALL ZHER2K( 'U', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2785 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2786 INFOT = 12
2787 CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 )
2788 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2789 INFOT = 12
2790 CALL ZHER2K( 'L', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 )
2791 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2792 GO TO 100
2793 90 INFOT = 1
2794 CALL ZSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2795 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2796 INFOT = 2
2797 CALL ZSYR2K( 'U', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2798 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2799 INFOT = 3
2800 CALL ZSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2801 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2802 INFOT = 3
2803 CALL ZSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2804 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2805 INFOT = 3
2806 CALL ZSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2807 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2808 INFOT = 3
2809 CALL ZSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2810 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2811 INFOT = 4
2812 CALL ZSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2813 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2814 INFOT = 4
2815 CALL ZSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2816 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2817 INFOT = 4
2818 CALL ZSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2819 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2820 INFOT = 4
2821 CALL ZSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2822 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2823 INFOT = 7
2824 CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2825 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2826 INFOT = 7
2827 CALL ZSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2828 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2829 INFOT = 7
2830 CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2831 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2832 INFOT = 7
2833 CALL ZSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2834 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2835 INFOT = 9
2836 CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
2837 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2838 INFOT = 9
2839 CALL ZSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
2840 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2841 INFOT = 9
2842 CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
2843 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2844 INFOT = 9
2845 CALL ZSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
2846 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2847 INFOT = 12
2848 CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2849 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2850 INFOT = 12
2851 CALL ZSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2852 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2853 INFOT = 12
2854 CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2855 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2856 INFOT = 12
2857 CALL ZSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2858 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2859 *
2860 100 IF( OK )THEN
2861 WRITE( NOUT, FMT = 9999 )SRNAMT
2862 ELSE
2863 WRITE( NOUT, FMT = 9998 )SRNAMT
2864 END IF
2865 RETURN
2866 *
2867 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
2868 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
2869 $ '**' )
2870 *
2871 * End of ZCHKE.
2872 *
2873 END
2874 SUBROUTINE ZMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
2875 $ TRANSL )
2876 *
2877 * Generates values for an M by N matrix A.
2878 * Stores the values in the array AA in the data structure required
2879 * by the routine, with unwanted elements set to rogue value.
2880 *
2881 * TYPE is 'GE', 'HE', 'SY' or 'TR'.
2882 *
2883 * Auxiliary routine for test program for Level 3 Blas.
2884 *
2885 * -- Written on 8-February-1989.
2886 * Jack Dongarra, Argonne National Laboratory.
2887 * Iain Duff, AERE Harwell.
2888 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2889 * Sven Hammarling, Numerical Algorithms Group Ltd.
2890 *
2891 * .. Parameters ..
2892 COMPLEX*16 ZERO, ONE
2893 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ),
2894 $ ONE = ( 1.0D0, 0.0D0 ) )
2895 COMPLEX*16 ROGUE
2896 PARAMETER ( ROGUE = ( -1.0D10, 1.0D10 ) )
2897 DOUBLE PRECISION RZERO
2898 PARAMETER ( RZERO = 0.0D0 )
2899 DOUBLE PRECISION RROGUE
2900 PARAMETER ( RROGUE = -1.0D10 )
2901 * .. Scalar Arguments ..
2902 COMPLEX*16 TRANSL
2903 INTEGER LDA, M, N, NMAX
2904 LOGICAL RESET
2905 CHARACTER*1 DIAG, UPLO
2906 CHARACTER*2 TYPE
2907 * .. Array Arguments ..
2908 COMPLEX*16 A( NMAX, * ), AA( * )
2909 * .. Local Scalars ..
2910 INTEGER I, IBEG, IEND, J, JJ
2911 LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER
2912 * .. External Functions ..
2913 COMPLEX*16 ZBEG
2914 EXTERNAL ZBEG
2915 * .. Intrinsic Functions ..
2916 INTRINSIC DCMPLX, DCONJG, DBLE
2917 * .. Executable Statements ..
2918 GEN = TYPE.EQ.'GE'
2919 HER = TYPE.EQ.'HE'
2920 SYM = TYPE.EQ.'SY'
2921 TRI = TYPE.EQ.'TR'
2922 UPPER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'U'
2923 LOWER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'L'
2924 UNIT = TRI.AND.DIAG.EQ.'U'
2925 *
2926 * Generate data in array A.
2927 *
2928 DO 20 J = 1, N
2929 DO 10 I = 1, M
2930 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
2931 $ THEN
2932 A( I, J ) = ZBEG( RESET ) + TRANSL
2933 IF( I.NE.J )THEN
2934 * Set some elements to zero
2935 IF( N.GT.3.AND.J.EQ.N/2 )
2936 $ A( I, J ) = ZERO
2937 IF( HER )THEN
2938 A( J, I ) = DCONJG( A( I, J ) )
2939 ELSE IF( SYM )THEN
2940 A( J, I ) = A( I, J )
2941 ELSE IF( TRI )THEN
2942 A( J, I ) = ZERO
2943 END IF
2944 END IF
2945 END IF
2946 10 CONTINUE
2947 IF( HER )
2948 $ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), RZERO )
2949 IF( TRI )
2950 $ A( J, J ) = A( J, J ) + ONE
2951 IF( UNIT )
2952 $ A( J, J ) = ONE
2953 20 CONTINUE
2954 *
2955 * Store elements in array AS in data structure required by routine.
2956 *
2957 IF( TYPE.EQ.'GE' )THEN
2958 DO 50 J = 1, N
2959 DO 30 I = 1, M
2960 AA( I + ( J - 1 )*LDA ) = A( I, J )
2961 30 CONTINUE
2962 DO 40 I = M + 1, LDA
2963 AA( I + ( J - 1 )*LDA ) = ROGUE
2964 40 CONTINUE
2965 50 CONTINUE
2966 ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
2967 DO 90 J = 1, N
2968 IF( UPPER )THEN
2969 IBEG = 1
2970 IF( UNIT )THEN
2971 IEND = J - 1
2972 ELSE
2973 IEND = J
2974 END IF
2975 ELSE
2976 IF( UNIT )THEN
2977 IBEG = J + 1
2978 ELSE
2979 IBEG = J
2980 END IF
2981 IEND = N
2982 END IF
2983 DO 60 I = 1, IBEG - 1
2984 AA( I + ( J - 1 )*LDA ) = ROGUE
2985 60 CONTINUE
2986 DO 70 I = IBEG, IEND
2987 AA( I + ( J - 1 )*LDA ) = A( I, J )
2988 70 CONTINUE
2989 DO 80 I = IEND + 1, LDA
2990 AA( I + ( J - 1 )*LDA ) = ROGUE
2991 80 CONTINUE
2992 IF( HER )THEN
2993 JJ = J + ( J - 1 )*LDA
2994 AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE )
2995 END IF
2996 90 CONTINUE
2997 END IF
2998 RETURN
2999 *
3000 * End of ZMAKE.
3001 *
3002 END
3003 SUBROUTINE ZMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
3004 $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
3005 $ NOUT, MV )
3006 *
3007 * Checks the results of the computational tests.
3008 *
3009 * Auxiliary routine for test program for Level 3 Blas.
3010 *
3011 * -- Written on 8-February-1989.
3012 * Jack Dongarra, Argonne National Laboratory.
3013 * Iain Duff, AERE Harwell.
3014 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3015 * Sven Hammarling, Numerical Algorithms Group Ltd.
3016 *
3017 * .. Parameters ..
3018 COMPLEX*16 ZERO
3019 PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) )
3020 DOUBLE PRECISION RZERO, RONE
3021 PARAMETER ( RZERO = 0.0D0, RONE = 1.0D0 )
3022 * .. Scalar Arguments ..
3023 COMPLEX*16 ALPHA, BETA
3024 DOUBLE PRECISION EPS, ERR
3025 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
3026 LOGICAL FATAL, MV
3027 CHARACTER*1 TRANSA, TRANSB
3028 * .. Array Arguments ..
3029 COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ),
3030 $ CC( LDCC, * ), CT( * )
3031 DOUBLE PRECISION G( * )
3032 * .. Local Scalars ..
3033 COMPLEX*16 CL
3034 DOUBLE PRECISION ERRI
3035 INTEGER I, J, K
3036 LOGICAL CTRANA, CTRANB, TRANA, TRANB
3037 * .. Intrinsic Functions ..
3038 INTRINSIC ABS, DIMAG, DCONJG, MAX, DBLE, SQRT
3039 * .. Statement Functions ..
3040 DOUBLE PRECISION ABS1
3041 * .. Statement Function definitions ..
3042 ABS1( CL ) = ABS( DBLE( CL ) ) + ABS( DIMAG( CL ) )
3043 * .. Executable Statements ..
3044 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
3045 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
3046 CTRANA = TRANSA.EQ.'C'
3047 CTRANB = TRANSB.EQ.'C'
3048 *
3049 * Compute expected result, one column at a time, in CT using data
3050 * in A, B and C.
3051 * Compute gauges in G.
3052 *
3053 DO 220 J = 1, N
3054 *
3055 DO 10 I = 1, M
3056 CT( I ) = ZERO
3057 G( I ) = RZERO
3058 10 CONTINUE
3059 IF( .NOT.TRANA.AND..NOT.TRANB )THEN
3060 DO 30 K = 1, KK
3061 DO 20 I = 1, M
3062 CT( I ) = CT( I ) + A( I, K )*B( K, J )
3063 G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) )
3064 20 CONTINUE
3065 30 CONTINUE
3066 ELSE IF( TRANA.AND..NOT.TRANB )THEN
3067 IF( CTRANA )THEN
3068 DO 50 K = 1, KK
3069 DO 40 I = 1, M
3070 CT( I ) = CT( I ) + DCONJG( A( K, I ) )*B( K, J )
3071 G( I ) = G( I ) + ABS1( A( K, I ) )*
3072 $ ABS1( B( K, J ) )
3073 40 CONTINUE
3074 50 CONTINUE
3075 ELSE
3076 DO 70 K = 1, KK
3077 DO 60 I = 1, M
3078 CT( I ) = CT( I ) + A( K, I )*B( K, J )
3079 G( I ) = G( I ) + ABS1( A( K, I ) )*
3080 $ ABS1( B( K, J ) )
3081 60 CONTINUE
3082 70 CONTINUE
3083 END IF
3084 ELSE IF( .NOT.TRANA.AND.TRANB )THEN
3085 IF( CTRANB )THEN
3086 DO 90 K = 1, KK
3087 DO 80 I = 1, M
3088 CT( I ) = CT( I ) + A( I, K )*DCONJG( B( J, K ) )
3089 G( I ) = G( I ) + ABS1( A( I, K ) )*
3090 $ ABS1( B( J, K ) )
3091 80 CONTINUE
3092 90 CONTINUE
3093 ELSE
3094 DO 110 K = 1, KK
3095 DO 100 I = 1, M
3096 CT( I ) = CT( I ) + A( I, K )*B( J, K )
3097 G( I ) = G( I ) + ABS1( A( I, K ) )*
3098 $ ABS1( B( J, K ) )
3099 100 CONTINUE
3100 110 CONTINUE
3101 END IF
3102 ELSE IF( TRANA.AND.TRANB )THEN
3103 IF( CTRANA )THEN
3104 IF( CTRANB )THEN
3105 DO 130 K = 1, KK
3106 DO 120 I = 1, M
3107 CT( I ) = CT( I ) + DCONJG( A( K, I ) )*
3108 $ DCONJG( B( J, K ) )
3109 G( I ) = G( I ) + ABS1( A( K, I ) )*
3110 $ ABS1( B( J, K ) )
3111 120 CONTINUE
3112 130 CONTINUE
3113 ELSE
3114 DO 150 K = 1, KK
3115 DO 140 I = 1, M
3116 CT( I ) = CT( I ) + DCONJG( A( K, I ) )*
3117 $ B( J, K )
3118 G( I ) = G( I ) + ABS1( A( K, I ) )*
3119 $ ABS1( B( J, K ) )
3120 140 CONTINUE
3121 150 CONTINUE
3122 END IF
3123 ELSE
3124 IF( CTRANB )THEN
3125 DO 170 K = 1, KK
3126 DO 160 I = 1, M
3127 CT( I ) = CT( I ) + A( K, I )*
3128 $ DCONJG( B( J, K ) )
3129 G( I ) = G( I ) + ABS1( A( K, I ) )*
3130 $ ABS1( B( J, K ) )
3131 160 CONTINUE
3132 170 CONTINUE
3133 ELSE
3134 DO 190 K = 1, KK
3135 DO 180 I = 1, M
3136 CT( I ) = CT( I ) + A( K, I )*B( J, K )
3137 G( I ) = G( I ) + ABS1( A( K, I ) )*
3138 $ ABS1( B( J, K ) )
3139 180 CONTINUE
3140 190 CONTINUE
3141 END IF
3142 END IF
3143 END IF
3144 DO 200 I = 1, M
3145 CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
3146 G( I ) = ABS1( ALPHA )*G( I ) +
3147 $ ABS1( BETA )*ABS1( C( I, J ) )
3148 200 CONTINUE
3149 *
3150 * Compute the error ratio for this result.
3151 *
3152 ERR = ZERO
3153 DO 210 I = 1, M
3154 ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS
3155 IF( G( I ).NE.RZERO )
3156 $ ERRI = ERRI/G( I )
3157 ERR = MAX( ERR, ERRI )
3158 IF( ERR*SQRT( EPS ).GE.RONE )
3159 $ GO TO 230
3160 210 CONTINUE
3161 *
3162 220 CONTINUE
3163 *
3164 * If the loop completes, all results are at least half accurate.
3165 GO TO 250
3166 *
3167 * Report fatal error.
3168 *
3169 230 FATAL = .TRUE.
3170 WRITE( NOUT, FMT = 9999 )
3171 DO 240 I = 1, M
3172 IF( MV )THEN
3173 WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
3174 ELSE
3175 WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
3176 END IF
3177 240 CONTINUE
3178 IF( N.GT.1 )
3179 $ WRITE( NOUT, FMT = 9997 )J
3180 *
3181 250 CONTINUE
3182 RETURN
3183 *
3184 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3185 $ 'F ACCURATE *******', /' EXPECTED RE',
3186 $ 'SULT COMPUTED RESULT' )
3187 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) )
3188 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
3189 *
3190 * End of ZMMCH.
3191 *
3192 END
3193 LOGICAL FUNCTION LZE( RI, RJ, LR )
3194 *
3195 * Tests if two arrays are identical.
3196 *
3197 * Auxiliary routine for test program for Level 3 Blas.
3198 *
3199 * -- Written on 8-February-1989.
3200 * Jack Dongarra, Argonne National Laboratory.
3201 * Iain Duff, AERE Harwell.
3202 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3203 * Sven Hammarling, Numerical Algorithms Group Ltd.
3204 *
3205 * .. Scalar Arguments ..
3206 INTEGER LR
3207 * .. Array Arguments ..
3208 COMPLEX*16 RI( * ), RJ( * )
3209 * .. Local Scalars ..
3210 INTEGER I
3211 * .. Executable Statements ..
3212 DO 10 I = 1, LR
3213 IF( RI( I ).NE.RJ( I ) )
3214 $ GO TO 20
3215 10 CONTINUE
3216 LZE = .TRUE.
3217 GO TO 30
3218 20 CONTINUE
3219 LZE = .FALSE.
3220 30 RETURN
3221 *
3222 * End of LZE.
3223 *
3224 END
3225 LOGICAL FUNCTION LZERES( TYPE, UPLO, M, N, AA, AS, LDA )
3226 *
3227 * Tests if selected elements in two arrays are equal.
3228 *
3229 * TYPE is 'GE' or 'HE' or 'SY'.
3230 *
3231 * Auxiliary routine for test program for Level 3 Blas.
3232 *
3233 * -- Written on 8-February-1989.
3234 * Jack Dongarra, Argonne National Laboratory.
3235 * Iain Duff, AERE Harwell.
3236 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3237 * Sven Hammarling, Numerical Algorithms Group Ltd.
3238 *
3239 * .. Scalar Arguments ..
3240 INTEGER LDA, M, N
3241 CHARACTER*1 UPLO
3242 CHARACTER*2 TYPE
3243 * .. Array Arguments ..
3244 COMPLEX*16 AA( LDA, * ), AS( LDA, * )
3245 * .. Local Scalars ..
3246 INTEGER I, IBEG, IEND, J
3247 LOGICAL UPPER
3248 * .. Executable Statements ..
3249 UPPER = UPLO.EQ.'U'
3250 IF( TYPE.EQ.'GE' )THEN
3251 DO 20 J = 1, N
3252 DO 10 I = M + 1, LDA
3253 IF( AA( I, J ).NE.AS( I, J ) )
3254 $ GO TO 70
3255 10 CONTINUE
3256 20 CONTINUE
3257 ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY' )THEN
3258 DO 50 J = 1, N
3259 IF( UPPER )THEN
3260 IBEG = 1
3261 IEND = J
3262 ELSE
3263 IBEG = J
3264 IEND = N
3265 END IF
3266 DO 30 I = 1, IBEG - 1
3267 IF( AA( I, J ).NE.AS( I, J ) )
3268 $ GO TO 70
3269 30 CONTINUE
3270 DO 40 I = IEND + 1, LDA
3271 IF( AA( I, J ).NE.AS( I, J ) )
3272 $ GO TO 70
3273 40 CONTINUE
3274 50 CONTINUE
3275 END IF
3276 *
3277 60 CONTINUE
3278 LZERES = .TRUE.
3279 GO TO 80
3280 70 CONTINUE
3281 LZERES = .FALSE.
3282 80 RETURN
3283 *
3284 * End of LZERES.
3285 *
3286 END
3287 COMPLEX*16 FUNCTION ZBEG( RESET )
3288 *
3289 * Generates complex numbers as pairs of random numbers uniformly
3290 * distributed between -0.5 and 0.5.
3291 *
3292 * Auxiliary routine for test program for Level 3 Blas.
3293 *
3294 * -- Written on 8-February-1989.
3295 * Jack Dongarra, Argonne National Laboratory.
3296 * Iain Duff, AERE Harwell.
3297 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3298 * Sven Hammarling, Numerical Algorithms Group Ltd.
3299 *
3300 * .. Scalar Arguments ..
3301 LOGICAL RESET
3302 * .. Local Scalars ..
3303 INTEGER I, IC, J, MI, MJ
3304 * .. Save statement ..
3305 SAVE I, IC, J, MI, MJ
3306 * .. Intrinsic Functions ..
3307 INTRINSIC DCMPLX
3308 * .. Executable Statements ..
3309 IF( RESET )THEN
3310 * Initialize local variables.
3311 MI = 891
3312 MJ = 457
3313 I = 7
3314 J = 7
3315 IC = 0
3316 RESET = .FALSE.
3317 END IF
3318 *
3319 * The sequence of values of I or J is bounded between 1 and 999.
3320 * If initial I or J = 1,2,3,6,7 or 9, the period will be 50.
3321 * If initial I or J = 4 or 8, the period will be 25.
3322 * If initial I or J = 5, the period will be 10.
3323 * IC is used to break up the period by skipping 1 value of I or J
3324 * in 6.
3325 *
3326 IC = IC + 1
3327 10 I = I*MI
3328 J = J*MJ
3329 I = I - 1000*( I/1000 )
3330 J = J - 1000*( J/1000 )
3331 IF( IC.GE.5 )THEN
3332 IC = 0
3333 GO TO 10
3334 END IF
3335 ZBEG = DCMPLX( ( I - 500 )/1001.0D0, ( J - 500 )/1001.0D0 )
3336 RETURN
3337 *
3338 * End of ZBEG.
3339 *
3340 END
3341 DOUBLE PRECISION FUNCTION DDIFF( X, Y )
3342 *
3343 * Auxiliary routine for test program for Level 3 Blas.
3344 *
3345 * -- Written on 8-February-1989.
3346 * Jack Dongarra, Argonne National Laboratory.
3347 * Iain Duff, AERE Harwell.
3348 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3349 * Sven Hammarling, Numerical Algorithms Group Ltd.
3350 *
3351 * .. Scalar Arguments ..
3352 DOUBLE PRECISION X, Y
3353 * .. Executable Statements ..
3354 DDIFF = X - Y
3355 RETURN
3356 *
3357 * End of DDIFF.
3358 *
3359 END
3360 SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
3361 *
3362 * Tests whether XERBLA has detected an error when it should.
3363 *
3364 * Auxiliary routine for test program for Level 3 Blas.
3365 *
3366 * -- Written on 8-February-1989.
3367 * Jack Dongarra, Argonne National Laboratory.
3368 * Iain Duff, AERE Harwell.
3369 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3370 * Sven Hammarling, Numerical Algorithms Group Ltd.
3371 *
3372 * .. Scalar Arguments ..
3373 INTEGER INFOT, NOUT
3374 LOGICAL LERR, OK
3375 CHARACTER*6 SRNAMT
3376 * .. Executable Statements ..
3377 IF( .NOT.LERR )THEN
3378 WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
3379 OK = .FALSE.
3380 END IF
3381 LERR = .FALSE.
3382 RETURN
3383 *
3384 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
3385 $ 'ETECTED BY ', A6, ' *****' )
3386 *
3387 * End of CHKXER.
3388 *
3389 END
3390 SUBROUTINE XERBLA( SRNAME, INFO )
3391 *
3392 * This is a special version of XERBLA to be used only as part of
3393 * the test program for testing error exits from the Level 3 BLAS
3394 * routines.
3395 *
3396 * XERBLA is an error handler for the Level 3 BLAS routines.
3397 *
3398 * It is called by the Level 3 BLAS routines if an input parameter is
3399 * invalid.
3400 *
3401 * Auxiliary routine for test program for Level 3 Blas.
3402 *
3403 * -- Written on 8-February-1989.
3404 * Jack Dongarra, Argonne National Laboratory.
3405 * Iain Duff, AERE Harwell.
3406 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
3407 * Sven Hammarling, Numerical Algorithms Group Ltd.
3408 *
3409 * .. Scalar Arguments ..
3410 INTEGER INFO
3411 CHARACTER*6 SRNAME
3412 * .. Scalars in Common ..
3413 INTEGER INFOT, NOUT
3414 LOGICAL LERR, OK
3415 CHARACTER*6 SRNAMT
3416 * .. Common blocks ..
3417 COMMON /INFOC/INFOT, NOUT, OK, LERR
3418 COMMON /SRNAMC/SRNAMT
3419 * .. Executable Statements ..
3420 LERR = .TRUE.
3421 IF( INFO.NE.INFOT )THEN
3422 IF( INFOT.NE.0 )THEN
3423 WRITE( NOUT, FMT = 9999 )INFO, INFOT
3424 ELSE
3425 WRITE( NOUT, FMT = 9997 )INFO
3426 END IF
3427 OK = .FALSE.
3428 END IF
3429 IF( SRNAME.NE.SRNAMT )THEN
3430 WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
3431 OK = .FALSE.
3432 END IF
3433 RETURN
3434 *
3435 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
3436 $ ' OF ', I2, ' *******' )
3437 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
3438 $ 'AD OF ', A6, ' *******' )
3439 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
3440 $ ' *******' )
3441 *
3442 * End of XERBLA
3443 *
3444 END
3445