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