LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 *
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
cblat2
program cblat2
CBLAT2
Definition: cblat2.f:104
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:2056
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:1772
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:1133
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:2911
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:786
lce
logical function lce(RI, RJ, LR)
Definition: cblat2.f:3042
sdiff
real function sdiff(SA, SB)
Definition: cblat1.f:645
cmake
subroutine cmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: cblat2.f:2719
lceres
logical function lceres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: cblat2.f:3072
cbeg
complex function cbeg(RESET)
Definition: cblat2.f:3131
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:1495
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:441