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