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