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