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