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