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