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