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