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