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