LAPACK  3.11.0
LAPACK: Linear Algebra PACKage
c_cblat2.f
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 *
423 10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
424 10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' )
425 10000 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