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