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