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