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