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