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