LAPACK  3.11.0
LAPACK: Linear Algebra PACKage
cblat2.f
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, cregr1
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 * Regression test to verify preservation of y when m zero, n nonzero.
738 *
739  CALL cregr1( trans, m, n, ly, kl, ku, alpha, aa, lda, xx, incx,
740  $ beta, yy, incy, ys )
741  IF( full )THEN
742  IF( trace )
743  $ WRITE( ntra, fmt = 9994 )nc, sname, trans, m, n, alpha, lda,
744  $ incx, beta, incy
745  IF( rewi )
746  $ rewind ntra
747  CALL cgemv( trans, m, n, alpha, aa, lda, xx, incx, beta, yy,
748  $ incy )
749  ELSE IF( banded )THEN
750  IF( trace )
751  $ WRITE( ntra, fmt = 9995 )nc, sname, trans, m, n, kl, ku,
752  $ alpha, lda, incx, beta, incy
753  IF( rewi )
754  $ rewind ntra
755  CALL cgbmv( trans, m, n, kl, ku, alpha, aa, lda, xx, incx,
756  $ beta, yy, incy )
757  END IF
758  nc = nc + 1
759  IF( .NOT.lce( ys, yy, ly ) )THEN
760  WRITE( nout, fmt = 9998 )nargs - 1
761  fatal = .true.
762  GO TO 130
763  END IF
764 *
765 * Report result.
766 *
767  IF( errmax.LT.thresh )THEN
768  WRITE( nout, fmt = 9999 )sname, nc
769  ELSE
770  WRITE( nout, fmt = 9997 )sname, nc, errmax
771  END IF
772  GO TO 140
773 *
774  130 CONTINUE
775  WRITE( nout, fmt = 9996 )sname
776  IF( full )THEN
777  WRITE( nout, fmt = 9994 )nc, sname, trans, m, n, alpha, lda,
778  $ incx, beta, incy
779  ELSE IF( banded )THEN
780  WRITE( nout, fmt = 9995 )nc, sname, trans, m, n, kl, ku,
781  $ alpha, lda, incx, beta, incy
782  END IF
783 *
784  140 CONTINUE
785  RETURN
786 *
787  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
788  $ 'S)' )
789  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
790  $ 'ANGED INCORRECTLY *******' )
791  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
792  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
793  $ ' - SUSPECT *******' )
794  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
795  9995 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', 4( i3, ',' ), '(',
796  $ f4.1, ',', f4.1, '), A,', i3, ', X,', i2, ',(', f4.1, ',',
797  $ f4.1, '), Y,', i2, ') .' )
798  9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', 2( i3, ',' ), '(',
799  $ f4.1, ',', f4.1, '), A,', i3, ', X,', i2, ',(', f4.1, ',',
800  $ f4.1, '), Y,', i2, ') .' )
801  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
802  $ '******' )
803 *
804 * End of CCHK1
805 *
806  END
807  SUBROUTINE cchk2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
808  $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
809  $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
810  $ XS, Y, YY, YS, YT, G )
811 *
812 * Tests CHEMV, CHBMV and CHPMV.
813 *
814 * Auxiliary routine for test program for Level 2 Blas.
815 *
816 * -- Written on 10-August-1987.
817 * Richard Hanson, Sandia National Labs.
818 * Jeremy Du Croz, NAG Central Office.
819 *
820 * .. Parameters ..
821  COMPLEX zero, half
822  parameter( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ) )
823  REAL rzero
824  parameter( rzero = 0.0 )
825 * .. Scalar Arguments ..
826  REAL eps, thresh
827  INTEGER incmax, nalf, nbet, nidim, ninc, nkb, nmax,
828  $ nout, ntra
829  LOGICAL fatal, rewi, trace
830  CHARACTER*6 sname
831 * .. Array Arguments ..
832  COMPLEX a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
833  $ as( nmax*nmax ), bet( nbet ), x( nmax ),
834  $ xs( nmax*incmax ), xx( nmax*incmax ),
835  $ y( nmax ), ys( nmax*incmax ), yt( nmax ),
836  $ yy( nmax*incmax )
837  REAL g( nmax )
838  INTEGER idim( nidim ), inc( ninc ), kb( nkb )
839 * .. Local Scalars ..
840  COMPLEX alpha, als, beta, bls, transl
841  REAL err, errmax
842  INTEGER i, ia, ib, ic, ik, in, incx, incxs, incy,
843  $ incys, ix, iy, k, ks, laa, lda, ldas, lx, ly,
844  $ n, nargs, nc, nk, ns
845  LOGICAL banded, full, null, packed, reset, same
846  CHARACTER*1 uplo, uplos
847  CHARACTER*2 ich
848 * .. Local Arrays ..
849  LOGICAL isame( 13 )
850 * .. External Functions ..
851  LOGICAL lce, lceres
852  EXTERNAL lce, lceres
853 * .. External Subroutines ..
854  EXTERNAL chbmv, chemv, chpmv, cmake, cmvch
855 * .. Intrinsic Functions ..
856  INTRINSIC abs, max
857 * .. Scalars in Common ..
858  INTEGER infot, noutc
859  LOGICAL lerr, ok
860 * .. Common blocks ..
861  COMMON /infoc/infot, noutc, ok, lerr
862 * .. Data statements ..
863  DATA ich/'UL'/
864 * .. Executable Statements ..
865  full = sname( 3: 3 ).EQ.'E'
866  banded = sname( 3: 3 ).EQ.'B'
867  packed = sname( 3: 3 ).EQ.'P'
868 * Define the number of arguments.
869  IF( full )THEN
870  nargs = 10
871  ELSE IF( banded )THEN
872  nargs = 11
873  ELSE IF( packed )THEN
874  nargs = 9
875  END IF
876 *
877  nc = 0
878  reset = .true.
879  errmax = rzero
880 *
881  DO 110 in = 1, nidim
882  n = idim( in )
883 *
884  IF( banded )THEN
885  nk = nkb
886  ELSE
887  nk = 1
888  END IF
889  DO 100 ik = 1, nk
890  IF( banded )THEN
891  k = kb( ik )
892  ELSE
893  k = n - 1
894  END IF
895 * Set LDA to 1 more than minimum value if room.
896  IF( banded )THEN
897  lda = k + 1
898  ELSE
899  lda = n
900  END IF
901  IF( lda.LT.nmax )
902  $ lda = lda + 1
903 * Skip tests if not enough room.
904  IF( lda.GT.nmax )
905  $ GO TO 100
906  IF( packed )THEN
907  laa = ( n*( n + 1 ) )/2
908  ELSE
909  laa = lda*n
910  END IF
911  null = n.LE.0
912 *
913  DO 90 ic = 1, 2
914  uplo = ich( ic: ic )
915 *
916 * Generate the matrix A.
917 *
918  transl = zero
919  CALL cmake( sname( 2: 3 ), uplo, ' ', n, n, a, nmax, aa,
920  $ lda, k, k, reset, transl )
921 *
922  DO 80 ix = 1, ninc
923  incx = inc( ix )
924  lx = abs( incx )*n
925 *
926 * Generate the vector X.
927 *
928  transl = half
929  CALL cmake( 'GE', ' ', ' ', 1, n, x, 1, xx,
930  $ abs( incx ), 0, n - 1, reset, transl )
931  IF( n.GT.1 )THEN
932  x( n/2 ) = zero
933  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
934  END IF
935 *
936  DO 70 iy = 1, ninc
937  incy = inc( iy )
938  ly = abs( incy )*n
939 *
940  DO 60 ia = 1, nalf
941  alpha = alf( ia )
942 *
943  DO 50 ib = 1, nbet
944  beta = bet( ib )
945 *
946 * Generate the vector Y.
947 *
948  transl = zero
949  CALL cmake( 'GE', ' ', ' ', 1, n, y, 1, yy,
950  $ abs( incy ), 0, n - 1, reset,
951  $ transl )
952 *
953  nc = nc + 1
954 *
955 * Save every datum before calling the
956 * subroutine.
957 *
958  uplos = uplo
959  ns = n
960  ks = k
961  als = alpha
962  DO 10 i = 1, laa
963  as( i ) = aa( i )
964  10 CONTINUE
965  ldas = lda
966  DO 20 i = 1, lx
967  xs( i ) = xx( i )
968  20 CONTINUE
969  incxs = incx
970  bls = beta
971  DO 30 i = 1, ly
972  ys( i ) = yy( i )
973  30 CONTINUE
974  incys = incy
975 *
976 * Call the subroutine.
977 *
978  IF( full )THEN
979  IF( trace )
980  $ WRITE( ntra, fmt = 9993 )nc, sname,
981  $ uplo, n, alpha, lda, incx, beta, incy
982  IF( rewi )
983  $ rewind ntra
984  CALL chemv( uplo, n, alpha, aa, lda, xx,
985  $ incx, beta, yy, incy )
986  ELSE IF( banded )THEN
987  IF( trace )
988  $ WRITE( ntra, fmt = 9994 )nc, sname,
989  $ uplo, n, k, alpha, lda, incx, beta,
990  $ incy
991  IF( rewi )
992  $ rewind ntra
993  CALL chbmv( uplo, n, k, alpha, aa, lda,
994  $ xx, incx, beta, yy, incy )
995  ELSE IF( packed )THEN
996  IF( trace )
997  $ WRITE( ntra, fmt = 9995 )nc, sname,
998  $ uplo, n, alpha, incx, beta, incy
999  IF( rewi )
1000  $ rewind ntra
1001  CALL chpmv( uplo, n, alpha, aa, xx, incx,
1002  $ beta, yy, incy )
1003  END IF
1004 *
1005 * Check if error-exit was taken incorrectly.
1006 *
1007  IF( .NOT.ok )THEN
1008  WRITE( nout, fmt = 9992 )
1009  fatal = .true.
1010  GO TO 120
1011  END IF
1012 *
1013 * See what data changed inside subroutines.
1014 *
1015  isame( 1 ) = uplo.EQ.uplos
1016  isame( 2 ) = ns.EQ.n
1017  IF( full )THEN
1018  isame( 3 ) = als.EQ.alpha
1019  isame( 4 ) = lce( as, aa, laa )
1020  isame( 5 ) = ldas.EQ.lda
1021  isame( 6 ) = lce( xs, xx, lx )
1022  isame( 7 ) = incxs.EQ.incx
1023  isame( 8 ) = bls.EQ.beta
1024  IF( null )THEN
1025  isame( 9 ) = lce( ys, yy, ly )
1026  ELSE
1027  isame( 9 ) = lceres( 'GE', ' ', 1, n,
1028  $ ys, yy, abs( incy ) )
1029  END IF
1030  isame( 10 ) = incys.EQ.incy
1031  ELSE IF( banded )THEN
1032  isame( 3 ) = ks.EQ.k
1033  isame( 4 ) = als.EQ.alpha
1034  isame( 5 ) = lce( as, aa, laa )
1035  isame( 6 ) = ldas.EQ.lda
1036  isame( 7 ) = lce( xs, xx, lx )
1037  isame( 8 ) = incxs.EQ.incx
1038  isame( 9 ) = bls.EQ.beta
1039  IF( null )THEN
1040  isame( 10 ) = lce( ys, yy, ly )
1041  ELSE
1042  isame( 10 ) = lceres( 'GE', ' ', 1, n,
1043  $ ys, yy, abs( incy ) )
1044  END IF
1045  isame( 11 ) = incys.EQ.incy
1046  ELSE IF( packed )THEN
1047  isame( 3 ) = als.EQ.alpha
1048  isame( 4 ) = lce( as, aa, laa )
1049  isame( 5 ) = lce( xs, xx, lx )
1050  isame( 6 ) = incxs.EQ.incx
1051  isame( 7 ) = bls.EQ.beta
1052  IF( null )THEN
1053  isame( 8 ) = lce( ys, yy, ly )
1054  ELSE
1055  isame( 8 ) = lceres( 'GE', ' ', 1, n,
1056  $ ys, yy, abs( incy ) )
1057  END IF
1058  isame( 9 ) = incys.EQ.incy
1059  END IF
1060 *
1061 * If data was incorrectly changed, report and
1062 * return.
1063 *
1064  same = .true.
1065  DO 40 i = 1, nargs
1066  same = same.AND.isame( i )
1067  IF( .NOT.isame( i ) )
1068  $ WRITE( nout, fmt = 9998 )i
1069  40 CONTINUE
1070  IF( .NOT.same )THEN
1071  fatal = .true.
1072  GO TO 120
1073  END IF
1074 *
1075  IF( .NOT.null )THEN
1076 *
1077 * Check the result.
1078 *
1079  CALL cmvch( 'N', n, n, alpha, a, nmax, x,
1080  $ incx, beta, y, incy, yt, g,
1081  $ yy, eps, err, fatal, nout,
1082  $ .true. )
1083  errmax = max( errmax, err )
1084 * If got really bad answer, report and
1085 * return.
1086  IF( fatal )
1087  $ GO TO 120
1088  ELSE
1089 * Avoid repeating tests with N.le.0
1090  GO TO 110
1091  END IF
1092 *
1093  50 CONTINUE
1094 *
1095  60 CONTINUE
1096 *
1097  70 CONTINUE
1098 *
1099  80 CONTINUE
1100 *
1101  90 CONTINUE
1102 *
1103  100 CONTINUE
1104 *
1105  110 CONTINUE
1106 *
1107 * Report result.
1108 *
1109  IF( errmax.LT.thresh )THEN
1110  WRITE( nout, fmt = 9999 )sname, nc
1111  ELSE
1112  WRITE( nout, fmt = 9997 )sname, nc, errmax
1113  END IF
1114  GO TO 130
1115 *
1116  120 CONTINUE
1117  WRITE( nout, fmt = 9996 )sname
1118  IF( full )THEN
1119  WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, lda, incx,
1120  $ beta, incy
1121  ELSE IF( banded )THEN
1122  WRITE( nout, fmt = 9994 )nc, sname, uplo, n, k, alpha, lda,
1123  $ incx, beta, incy
1124  ELSE IF( packed )THEN
1125  WRITE( nout, fmt = 9995 )nc, sname, uplo, n, alpha, incx,
1126  $ beta, incy
1127  END IF
1128 *
1129  130 CONTINUE
1130  RETURN
1131 *
1132  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1133  $ 'S)' )
1134  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1135  $ 'ANGED INCORRECTLY *******' )
1136  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1137  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1138  $ ' - SUSPECT *******' )
1139  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1140  9995 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',(', f4.1, ',',
1141  $ f4.1, '), AP, X,', i2, ',(', f4.1, ',', f4.1, '), Y,', i2,
1142  $ ') .' )
1143  9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', 2( i3, ',' ), '(',
1144  $ f4.1, ',', f4.1, '), A,', i3, ', X,', i2, ',(', f4.1, ',',
1145  $ f4.1, '), Y,', i2, ') .' )
1146  9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',(', f4.1, ',',
1147  $ f4.1, '), A,', i3, ', X,', i2, ',(', f4.1, ',', f4.1, '), ',
1148  $ 'Y,', i2, ') .' )
1149  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1150  $ '******' )
1151 *
1152 * End of CCHK2
1153 *
1154  END
1155  SUBROUTINE cchk3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1156  $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
1157  $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z )
1158 *
1159 * Tests CTRMV, CTBMV, CTPMV, CTRSV, CTBSV and CTPSV.
1160 *
1161 * Auxiliary routine for test program for Level 2 Blas.
1162 *
1163 * -- Written on 10-August-1987.
1164 * Richard Hanson, Sandia National Labs.
1165 * Jeremy Du Croz, NAG Central Office.
1166 *
1167 * .. Parameters ..
1168  COMPLEX zero, half, one
1169  parameter( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
1170  $ one = ( 1.0, 0.0 ) )
1171  REAL rzero
1172  parameter( rzero = 0.0 )
1173 * .. Scalar Arguments ..
1174  REAL eps, thresh
1175  INTEGER incmax, nidim, ninc, nkb, nmax, nout, ntra
1176  LOGICAL fatal, rewi, trace
1177  CHARACTER*6 sname
1178 * .. Array Arguments ..
1179  COMPLEX a( nmax, nmax ), aa( nmax*nmax ),
1180  $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
1181  $ xt( nmax ), xx( nmax*incmax ), z( nmax )
1182  REAL g( nmax )
1183  INTEGER idim( nidim ), inc( ninc ), kb( nkb )
1184 * .. Local Scalars ..
1185  COMPLEX transl
1186  REAL err, errmax
1187  INTEGER i, icd, ict, icu, ik, in, incx, incxs, ix, k,
1188  $ ks, laa, lda, ldas, lx, n, nargs, nc, nk, ns
1189  LOGICAL banded, full, null, packed, reset, same
1190  CHARACTER*1 diag, diags, trans, transs, uplo, uplos
1191  CHARACTER*2 ichd, ichu
1192  CHARACTER*3 icht
1193 * .. Local Arrays ..
1194  LOGICAL isame( 13 )
1195 * .. External Functions ..
1196  LOGICAL lce, lceres
1197  EXTERNAL lce, lceres
1198 * .. External Subroutines ..
1199  EXTERNAL cmake, cmvch, ctbmv, ctbsv, ctpmv, ctpsv,
1200  $ ctrmv, ctrsv
1201 * .. Intrinsic Functions ..
1202  INTRINSIC abs, max
1203 * .. Scalars in Common ..
1204  INTEGER infot, noutc
1205  LOGICAL lerr, ok
1206 * .. Common blocks ..
1207  COMMON /infoc/infot, noutc, ok, lerr
1208 * .. Data statements ..
1209  DATA ichu/'UL'/, icht/'NTC'/, ichd/'UN'/
1210 * .. Executable Statements ..
1211  full = sname( 3: 3 ).EQ.'R'
1212  banded = sname( 3: 3 ).EQ.'B'
1213  packed = sname( 3: 3 ).EQ.'P'
1214 * Define the number of arguments.
1215  IF( full )THEN
1216  nargs = 8
1217  ELSE IF( banded )THEN
1218  nargs = 9
1219  ELSE IF( packed )THEN
1220  nargs = 7
1221  END IF
1222 *
1223  nc = 0
1224  reset = .true.
1225  errmax = rzero
1226 * Set up zero vector for CMVCH.
1227  DO 10 i = 1, nmax
1228  z( i ) = zero
1229  10 CONTINUE
1230 *
1231  DO 110 in = 1, nidim
1232  n = idim( in )
1233 *
1234  IF( banded )THEN
1235  nk = nkb
1236  ELSE
1237  nk = 1
1238  END IF
1239  DO 100 ik = 1, nk
1240  IF( banded )THEN
1241  k = kb( ik )
1242  ELSE
1243  k = n - 1
1244  END IF
1245 * Set LDA to 1 more than minimum value if room.
1246  IF( banded )THEN
1247  lda = k + 1
1248  ELSE
1249  lda = n
1250  END IF
1251  IF( lda.LT.nmax )
1252  $ lda = lda + 1
1253 * Skip tests if not enough room.
1254  IF( lda.GT.nmax )
1255  $ GO TO 100
1256  IF( packed )THEN
1257  laa = ( n*( n + 1 ) )/2
1258  ELSE
1259  laa = lda*n
1260  END IF
1261  null = n.LE.0
1262 *
1263  DO 90 icu = 1, 2
1264  uplo = ichu( icu: icu )
1265 *
1266  DO 80 ict = 1, 3
1267  trans = icht( ict: ict )
1268 *
1269  DO 70 icd = 1, 2
1270  diag = ichd( icd: icd )
1271 *
1272 * Generate the matrix A.
1273 *
1274  transl = zero
1275  CALL cmake( sname( 2: 3 ), uplo, diag, n, n, a,
1276  $ nmax, aa, lda, k, k, reset, transl )
1277 *
1278  DO 60 ix = 1, ninc
1279  incx = inc( ix )
1280  lx = abs( incx )*n
1281 *
1282 * Generate the vector X.
1283 *
1284  transl = half
1285  CALL cmake( 'GE', ' ', ' ', 1, n, x, 1, xx,
1286  $ abs( incx ), 0, n - 1, reset,
1287  $ transl )
1288  IF( n.GT.1 )THEN
1289  x( n/2 ) = zero
1290  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1291  END IF
1292 *
1293  nc = nc + 1
1294 *
1295 * Save every datum before calling the subroutine.
1296 *
1297  uplos = uplo
1298  transs = trans
1299  diags = diag
1300  ns = n
1301  ks = k
1302  DO 20 i = 1, laa
1303  as( i ) = aa( i )
1304  20 CONTINUE
1305  ldas = lda
1306  DO 30 i = 1, lx
1307  xs( i ) = xx( i )
1308  30 CONTINUE
1309  incxs = incx
1310 *
1311 * Call the subroutine.
1312 *
1313  IF( sname( 4: 5 ).EQ.'MV' )THEN
1314  IF( full )THEN
1315  IF( trace )
1316  $ WRITE( ntra, fmt = 9993 )nc, sname,
1317  $ uplo, trans, diag, n, lda, incx
1318  IF( rewi )
1319  $ rewind ntra
1320  CALL ctrmv( uplo, trans, diag, n, aa, lda,
1321  $ xx, incx )
1322  ELSE IF( banded )THEN
1323  IF( trace )
1324  $ WRITE( ntra, fmt = 9994 )nc, sname,
1325  $ uplo, trans, diag, n, k, lda, incx
1326  IF( rewi )
1327  $ rewind ntra
1328  CALL ctbmv( uplo, trans, diag, n, k, aa,
1329  $ lda, xx, incx )
1330  ELSE IF( packed )THEN
1331  IF( trace )
1332  $ WRITE( ntra, fmt = 9995 )nc, sname,
1333  $ uplo, trans, diag, n, incx
1334  IF( rewi )
1335  $ rewind ntra
1336  CALL ctpmv( uplo, trans, diag, n, aa, xx,
1337  $ incx )
1338  END IF
1339  ELSE IF( sname( 4: 5 ).EQ.'SV' )THEN
1340  IF( full )THEN
1341  IF( trace )
1342  $ WRITE( ntra, fmt = 9993 )nc, sname,
1343  $ uplo, trans, diag, n, lda, incx
1344  IF( rewi )
1345  $ rewind ntra
1346  CALL ctrsv( uplo, trans, diag, n, aa, lda,
1347  $ xx, incx )
1348  ELSE IF( banded )THEN
1349  IF( trace )
1350  $ WRITE( ntra, fmt = 9994 )nc, sname,
1351  $ uplo, trans, diag, n, k, lda, incx
1352  IF( rewi )
1353  $ rewind ntra
1354  CALL ctbsv( uplo, trans, diag, n, k, aa,
1355  $ lda, xx, incx )
1356  ELSE IF( packed )THEN
1357  IF( trace )
1358  $ WRITE( ntra, fmt = 9995 )nc, sname,
1359  $ uplo, trans, diag, n, incx
1360  IF( rewi )
1361  $ rewind ntra
1362  CALL ctpsv( uplo, trans, diag, n, aa, xx,
1363  $ incx )
1364  END IF
1365  END IF
1366 *
1367 * Check if error-exit was taken incorrectly.
1368 *
1369  IF( .NOT.ok )THEN
1370  WRITE( nout, fmt = 9992 )
1371  fatal = .true.
1372  GO TO 120
1373  END IF
1374 *
1375 * See what data changed inside subroutines.
1376 *
1377  isame( 1 ) = uplo.EQ.uplos
1378  isame( 2 ) = trans.EQ.transs
1379  isame( 3 ) = diag.EQ.diags
1380  isame( 4 ) = ns.EQ.n
1381  IF( full )THEN
1382  isame( 5 ) = lce( as, aa, laa )
1383  isame( 6 ) = ldas.EQ.lda
1384  IF( null )THEN
1385  isame( 7 ) = lce( xs, xx, lx )
1386  ELSE
1387  isame( 7 ) = lceres( 'GE', ' ', 1, n, xs,
1388  $ xx, abs( incx ) )
1389  END IF
1390  isame( 8 ) = incxs.EQ.incx
1391  ELSE IF( banded )THEN
1392  isame( 5 ) = ks.EQ.k
1393  isame( 6 ) = lce( as, aa, laa )
1394  isame( 7 ) = ldas.EQ.lda
1395  IF( null )THEN
1396  isame( 8 ) = lce( xs, xx, lx )
1397  ELSE
1398  isame( 8 ) = lceres( 'GE', ' ', 1, n, xs,
1399  $ xx, abs( incx ) )
1400  END IF
1401  isame( 9 ) = incxs.EQ.incx
1402  ELSE IF( packed )THEN
1403  isame( 5 ) = lce( as, aa, laa )
1404  IF( null )THEN
1405  isame( 6 ) = lce( xs, xx, lx )
1406  ELSE
1407  isame( 6 ) = lceres( 'GE', ' ', 1, n, xs,
1408  $ xx, abs( incx ) )
1409  END IF
1410  isame( 7 ) = incxs.EQ.incx
1411  END IF
1412 *
1413 * If data was incorrectly changed, report and
1414 * return.
1415 *
1416  same = .true.
1417  DO 40 i = 1, nargs
1418  same = same.AND.isame( i )
1419  IF( .NOT.isame( i ) )
1420  $ WRITE( nout, fmt = 9998 )i
1421  40 CONTINUE
1422  IF( .NOT.same )THEN
1423  fatal = .true.
1424  GO TO 120
1425  END IF
1426 *
1427  IF( .NOT.null )THEN
1428  IF( sname( 4: 5 ).EQ.'MV' )THEN
1429 *
1430 * Check the result.
1431 *
1432  CALL cmvch( trans, n, n, one, a, nmax, x,
1433  $ incx, zero, z, incx, xt, g,
1434  $ xx, eps, err, fatal, nout,
1435  $ .true. )
1436  ELSE IF( sname( 4: 5 ).EQ.'SV' )THEN
1437 *
1438 * Compute approximation to original vector.
1439 *
1440  DO 50 i = 1, n
1441  z( i ) = xx( 1 + ( i - 1 )*
1442  $ abs( incx ) )
1443  xx( 1 + ( i - 1 )*abs( incx ) )
1444  $ = x( i )
1445  50 CONTINUE
1446  CALL cmvch( trans, n, n, one, a, nmax, z,
1447  $ incx, zero, x, incx, xt, g,
1448  $ xx, eps, err, fatal, nout,
1449  $ .false. )
1450  END IF
1451  errmax = max( errmax, err )
1452 * If got really bad answer, report and return.
1453  IF( fatal )
1454  $ GO TO 120
1455  ELSE
1456 * Avoid repeating tests with N.le.0.
1457  GO TO 110
1458  END IF
1459 *
1460  60 CONTINUE
1461 *
1462  70 CONTINUE
1463 *
1464  80 CONTINUE
1465 *
1466  90 CONTINUE
1467 *
1468  100 CONTINUE
1469 *
1470  110 CONTINUE
1471 *
1472 * Report result.
1473 *
1474  IF( errmax.LT.thresh )THEN
1475  WRITE( nout, fmt = 9999 )sname, nc
1476  ELSE
1477  WRITE( nout, fmt = 9997 )sname, nc, errmax
1478  END IF
1479  GO TO 130
1480 *
1481  120 CONTINUE
1482  WRITE( nout, fmt = 9996 )sname
1483  IF( full )THEN
1484  WRITE( nout, fmt = 9993 )nc, sname, uplo, trans, diag, n, lda,
1485  $ incx
1486  ELSE IF( banded )THEN
1487  WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, diag, n, k,
1488  $ lda, incx
1489  ELSE IF( packed )THEN
1490  WRITE( nout, fmt = 9995 )nc, sname, uplo, trans, diag, n, incx
1491  END IF
1492 *
1493  130 CONTINUE
1494  RETURN
1495 *
1496  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1497  $ 'S)' )
1498  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1499  $ 'ANGED INCORRECTLY *******' )
1500  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1501  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1502  $ ' - SUSPECT *******' )
1503  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1504  9995 FORMAT( 1x, i6, ': ', a6, '(', 3( '''', a1, ''',' ), i3, ', AP, ',
1505  $ 'X,', i2, ') .' )
1506  9994 FORMAT( 1x, i6, ': ', a6, '(', 3( '''', a1, ''',' ), 2( i3, ',' ),
1507  $ ' A,', i3, ', X,', i2, ') .' )
1508  9993 FORMAT( 1x, i6, ': ', a6, '(', 3( '''', a1, ''',' ), i3, ', A,',
1509  $ i3, ', X,', i2, ') .' )
1510  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1511  $ '******' )
1512 *
1513 * End of CCHK3
1514 *
1515  END
1516  SUBROUTINE cchk4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1517  $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1518  $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1519  $ Z )
1520 *
1521 * Tests CGERC and CGERU.
1522 *
1523 * Auxiliary routine for test program for Level 2 Blas.
1524 *
1525 * -- Written on 10-August-1987.
1526 * Richard Hanson, Sandia National Labs.
1527 * Jeremy Du Croz, NAG Central Office.
1528 *
1529 * .. Parameters ..
1530  COMPLEX zero, half, one
1531  parameter( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
1532  $ one = ( 1.0, 0.0 ) )
1533  REAL rzero
1534  parameter( rzero = 0.0 )
1535 * .. Scalar Arguments ..
1536  REAL eps, thresh
1537  INTEGER incmax, nalf, nidim, ninc, nmax, nout, ntra
1538  LOGICAL fatal, rewi, trace
1539  CHARACTER*6 sname
1540 * .. Array Arguments ..
1541  COMPLEX a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
1542  $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
1543  $ xx( nmax*incmax ), y( nmax ),
1544  $ ys( nmax*incmax ), yt( nmax ),
1545  $ yy( nmax*incmax ), z( nmax )
1546  REAL g( nmax )
1547  INTEGER idim( nidim ), inc( ninc )
1548 * .. Local Scalars ..
1549  COMPLEX alpha, als, transl
1550  REAL err, errmax
1551  INTEGER i, ia, im, in, incx, incxs, incy, incys, ix,
1552  $ iy, j, laa, lda, ldas, lx, ly, m, ms, n, nargs,
1553  $ nc, nd, ns
1554  LOGICAL conj, null, reset, same
1555 * .. Local Arrays ..
1556  COMPLEX w( 1 )
1557  LOGICAL isame( 13 )
1558 * .. External Functions ..
1559  LOGICAL lce, lceres
1560  EXTERNAL lce, lceres
1561 * .. External Subroutines ..
1562  EXTERNAL cgerc, cgeru, cmake, cmvch
1563 * .. Intrinsic Functions ..
1564  INTRINSIC abs, conjg, max, min
1565 * .. Scalars in Common ..
1566  INTEGER infot, noutc
1567  LOGICAL lerr, ok
1568 * .. Common blocks ..
1569  COMMON /infoc/infot, noutc, ok, lerr
1570 * .. Executable Statements ..
1571  conj = sname( 5: 5 ).EQ.'C'
1572 * Define the number of arguments.
1573  nargs = 9
1574 *
1575  nc = 0
1576  reset = .true.
1577  errmax = rzero
1578 *
1579  DO 120 in = 1, nidim
1580  n = idim( in )
1581  nd = n/2 + 1
1582 *
1583  DO 110 im = 1, 2
1584  IF( im.EQ.1 )
1585  $ m = max( n - nd, 0 )
1586  IF( im.EQ.2 )
1587  $ m = min( n + nd, nmax )
1588 *
1589 * Set LDA to 1 more than minimum value if room.
1590  lda = m
1591  IF( lda.LT.nmax )
1592  $ lda = lda + 1
1593 * Skip tests if not enough room.
1594  IF( lda.GT.nmax )
1595  $ GO TO 110
1596  laa = lda*n
1597  null = n.LE.0.OR.m.LE.0
1598 *
1599  DO 100 ix = 1, ninc
1600  incx = inc( ix )
1601  lx = abs( incx )*m
1602 *
1603 * Generate the vector X.
1604 *
1605  transl = half
1606  CALL cmake( 'GE', ' ', ' ', 1, m, x, 1, xx, abs( incx ),
1607  $ 0, m - 1, reset, transl )
1608  IF( m.GT.1 )THEN
1609  x( m/2 ) = zero
1610  xx( 1 + abs( incx )*( m/2 - 1 ) ) = zero
1611  END IF
1612 *
1613  DO 90 iy = 1, ninc
1614  incy = inc( iy )
1615  ly = abs( incy )*n
1616 *
1617 * Generate the vector Y.
1618 *
1619  transl = zero
1620  CALL cmake( 'GE', ' ', ' ', 1, n, y, 1, yy,
1621  $ abs( incy ), 0, n - 1, reset, transl )
1622  IF( n.GT.1 )THEN
1623  y( n/2 ) = zero
1624  yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
1625  END IF
1626 *
1627  DO 80 ia = 1, nalf
1628  alpha = alf( ia )
1629 *
1630 * Generate the matrix A.
1631 *
1632  transl = zero
1633  CALL cmake( sname( 2: 3 ), ' ', ' ', m, n, a, nmax,
1634  $ aa, lda, m - 1, n - 1, reset, transl )
1635 *
1636  nc = nc + 1
1637 *
1638 * Save every datum before calling the subroutine.
1639 *
1640  ms = m
1641  ns = n
1642  als = alpha
1643  DO 10 i = 1, laa
1644  as( i ) = aa( i )
1645  10 CONTINUE
1646  ldas = lda
1647  DO 20 i = 1, lx
1648  xs( i ) = xx( i )
1649  20 CONTINUE
1650  incxs = incx
1651  DO 30 i = 1, ly
1652  ys( i ) = yy( i )
1653  30 CONTINUE
1654  incys = incy
1655 *
1656 * Call the subroutine.
1657 *
1658  IF( trace )
1659  $ WRITE( ntra, fmt = 9994 )nc, sname, m, n,
1660  $ alpha, incx, incy, lda
1661  IF( conj )THEN
1662  IF( rewi )
1663  $ rewind ntra
1664  CALL cgerc( m, n, alpha, xx, incx, yy, incy, aa,
1665  $ lda )
1666  ELSE
1667  IF( rewi )
1668  $ rewind ntra
1669  CALL cgeru( m, n, alpha, xx, incx, yy, incy, aa,
1670  $ lda )
1671  END IF
1672 *
1673 * Check if error-exit was taken incorrectly.
1674 *
1675  IF( .NOT.ok )THEN
1676  WRITE( nout, fmt = 9993 )
1677  fatal = .true.
1678  GO TO 140
1679  END IF
1680 *
1681 * See what data changed inside subroutine.
1682 *
1683  isame( 1 ) = ms.EQ.m
1684  isame( 2 ) = ns.EQ.n
1685  isame( 3 ) = als.EQ.alpha
1686  isame( 4 ) = lce( xs, xx, lx )
1687  isame( 5 ) = incxs.EQ.incx
1688  isame( 6 ) = lce( ys, yy, ly )
1689  isame( 7 ) = incys.EQ.incy
1690  IF( null )THEN
1691  isame( 8 ) = lce( as, aa, laa )
1692  ELSE
1693  isame( 8 ) = lceres( 'GE', ' ', m, n, as, aa,
1694  $ lda )
1695  END IF
1696  isame( 9 ) = ldas.EQ.lda
1697 *
1698 * If data was incorrectly changed, report and return.
1699 *
1700  same = .true.
1701  DO 40 i = 1, nargs
1702  same = same.AND.isame( i )
1703  IF( .NOT.isame( i ) )
1704  $ WRITE( nout, fmt = 9998 )i
1705  40 CONTINUE
1706  IF( .NOT.same )THEN
1707  fatal = .true.
1708  GO TO 140
1709  END IF
1710 *
1711  IF( .NOT.null )THEN
1712 *
1713 * Check the result column by column.
1714 *
1715  IF( incx.GT.0 )THEN
1716  DO 50 i = 1, m
1717  z( i ) = x( i )
1718  50 CONTINUE
1719  ELSE
1720  DO 60 i = 1, m
1721  z( i ) = x( m - i + 1 )
1722  60 CONTINUE
1723  END IF
1724  DO 70 j = 1, n
1725  IF( incy.GT.0 )THEN
1726  w( 1 ) = y( j )
1727  ELSE
1728  w( 1 ) = y( n - j + 1 )
1729  END IF
1730  IF( conj )
1731  $ w( 1 ) = conjg( w( 1 ) )
1732  CALL cmvch( 'N', m, 1, alpha, z, nmax, w, 1,
1733  $ one, a( 1, j ), 1, yt, g,
1734  $ aa( 1 + ( j - 1 )*lda ), eps,
1735  $ err, fatal, nout, .true. )
1736  errmax = max( errmax, err )
1737 * If got really bad answer, report and return.
1738  IF( fatal )
1739  $ GO TO 130
1740  70 CONTINUE
1741  ELSE
1742 * Avoid repeating tests with M.le.0 or N.le.0.
1743  GO TO 110
1744  END IF
1745 *
1746  80 CONTINUE
1747 *
1748  90 CONTINUE
1749 *
1750  100 CONTINUE
1751 *
1752  110 CONTINUE
1753 *
1754  120 CONTINUE
1755 *
1756 * Report result.
1757 *
1758  IF( errmax.LT.thresh )THEN
1759  WRITE( nout, fmt = 9999 )sname, nc
1760  ELSE
1761  WRITE( nout, fmt = 9997 )sname, nc, errmax
1762  END IF
1763  GO TO 150
1764 *
1765  130 CONTINUE
1766  WRITE( nout, fmt = 9995 )j
1767 *
1768  140 CONTINUE
1769  WRITE( nout, fmt = 9996 )sname
1770  WRITE( nout, fmt = 9994 )nc, sname, m, n, alpha, incx, incy, lda
1771 *
1772  150 CONTINUE
1773  RETURN
1774 *
1775  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1776  $ 'S)' )
1777  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1778  $ 'ANGED INCORRECTLY *******' )
1779  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1780  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1781  $ ' - SUSPECT *******' )
1782  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1783  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1784  9994 FORMAT( 1x, i6, ': ', a6, '(', 2( i3, ',' ), '(', f4.1, ',', f4.1,
1785  $ '), X,', i2, ', Y,', i2, ', A,', i3, ') ',
1786  $ ' .' )
1787  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1788  $ '******' )
1789 *
1790 * End of CCHK4
1791 *
1792  END
1793  SUBROUTINE cchk5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1794  $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1795  $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1796  $ Z )
1797 *
1798 * Tests CHER and CHPR.
1799 *
1800 * Auxiliary routine for test program for Level 2 Blas.
1801 *
1802 * -- Written on 10-August-1987.
1803 * Richard Hanson, Sandia National Labs.
1804 * Jeremy Du Croz, NAG Central Office.
1805 *
1806 * .. Parameters ..
1807  COMPLEX zero, half, one
1808  parameter( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
1809  $ one = ( 1.0, 0.0 ) )
1810  REAL rzero
1811  parameter( rzero = 0.0 )
1812 * .. Scalar Arguments ..
1813  REAL eps, thresh
1814  INTEGER incmax, nalf, nidim, ninc, nmax, nout, ntra
1815  LOGICAL fatal, rewi, trace
1816  CHARACTER*6 sname
1817 * .. Array Arguments ..
1818  COMPLEX a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
1819  $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
1820  $ xx( nmax*incmax ), y( nmax ),
1821  $ ys( nmax*incmax ), yt( nmax ),
1822  $ yy( nmax*incmax ), z( nmax )
1823  REAL g( nmax )
1824  INTEGER idim( nidim ), inc( ninc )
1825 * .. Local Scalars ..
1826  COMPLEX alpha, transl
1827  REAL err, errmax, ralpha, rals
1828  INTEGER i, ia, ic, in, incx, incxs, ix, j, ja, jj, laa,
1829  $ lda, ldas, lj, lx, n, nargs, nc, ns
1830  LOGICAL full, null, packed, reset, same, upper
1831  CHARACTER*1 uplo, uplos
1832  CHARACTER*2 ich
1833 * .. Local Arrays ..
1834  COMPLEX w( 1 )
1835  LOGICAL isame( 13 )
1836 * .. External Functions ..
1837  LOGICAL lce, lceres
1838  EXTERNAL lce, lceres
1839 * .. External Subroutines ..
1840  EXTERNAL cher, chpr, cmake, cmvch
1841 * .. Intrinsic Functions ..
1842  INTRINSIC abs, cmplx, conjg, max, real
1843 * .. Scalars in Common ..
1844  INTEGER infot, noutc
1845  LOGICAL lerr, ok
1846 * .. Common blocks ..
1847  COMMON /infoc/infot, noutc, ok, lerr
1848 * .. Data statements ..
1849  DATA ich/'UL'/
1850 * .. Executable Statements ..
1851  full = sname( 3: 3 ).EQ.'E'
1852  packed = sname( 3: 3 ).EQ.'P'
1853 * Define the number of arguments.
1854  IF( full )THEN
1855  nargs = 7
1856  ELSE IF( packed )THEN
1857  nargs = 6
1858  END IF
1859 *
1860  nc = 0
1861  reset = .true.
1862  errmax = rzero
1863 *
1864  DO 100 in = 1, nidim
1865  n = idim( in )
1866 * Set LDA to 1 more than minimum value if room.
1867  lda = n
1868  IF( lda.LT.nmax )
1869  $ lda = lda + 1
1870 * Skip tests if not enough room.
1871  IF( lda.GT.nmax )
1872  $ GO TO 100
1873  IF( packed )THEN
1874  laa = ( n*( n + 1 ) )/2
1875  ELSE
1876  laa = lda*n
1877  END IF
1878 *
1879  DO 90 ic = 1, 2
1880  uplo = ich( ic: ic )
1881  upper = uplo.EQ.'U'
1882 *
1883  DO 80 ix = 1, ninc
1884  incx = inc( ix )
1885  lx = abs( incx )*n
1886 *
1887 * Generate the vector X.
1888 *
1889  transl = half
1890  CALL cmake( 'GE', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
1891  $ 0, n - 1, reset, transl )
1892  IF( n.GT.1 )THEN
1893  x( n/2 ) = zero
1894  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1895  END IF
1896 *
1897  DO 70 ia = 1, nalf
1898  ralpha = REAL( ALF( IA ) )
1899  alpha = cmplx( ralpha, rzero )
1900  null = n.LE.0.OR.ralpha.EQ.rzero
1901 *
1902 * Generate the matrix A.
1903 *
1904  transl = zero
1905  CALL cmake( sname( 2: 3 ), uplo, ' ', n, n, a, nmax,
1906  $ aa, lda, n - 1, n - 1, reset, transl )
1907 *
1908  nc = nc + 1
1909 *
1910 * Save every datum before calling the subroutine.
1911 *
1912  uplos = uplo
1913  ns = n
1914  rals = ralpha
1915  DO 10 i = 1, laa
1916  as( i ) = aa( i )
1917  10 CONTINUE
1918  ldas = lda
1919  DO 20 i = 1, lx
1920  xs( i ) = xx( i )
1921  20 CONTINUE
1922  incxs = incx
1923 *
1924 * Call the subroutine.
1925 *
1926  IF( full )THEN
1927  IF( trace )
1928  $ WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
1929  $ ralpha, incx, lda
1930  IF( rewi )
1931  $ rewind ntra
1932  CALL cher( uplo, n, ralpha, xx, incx, aa, lda )
1933  ELSE IF( packed )THEN
1934  IF( trace )
1935  $ WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
1936  $ ralpha, incx
1937  IF( rewi )
1938  $ rewind ntra
1939  CALL chpr( uplo, n, ralpha, xx, incx, aa )
1940  END IF
1941 *
1942 * Check if error-exit was taken incorrectly.
1943 *
1944  IF( .NOT.ok )THEN
1945  WRITE( nout, fmt = 9992 )
1946  fatal = .true.
1947  GO TO 120
1948  END IF
1949 *
1950 * See what data changed inside subroutines.
1951 *
1952  isame( 1 ) = uplo.EQ.uplos
1953  isame( 2 ) = ns.EQ.n
1954  isame( 3 ) = rals.EQ.ralpha
1955  isame( 4 ) = lce( xs, xx, lx )
1956  isame( 5 ) = incxs.EQ.incx
1957  IF( null )THEN
1958  isame( 6 ) = lce( as, aa, laa )
1959  ELSE
1960  isame( 6 ) = lceres( sname( 2: 3 ), uplo, n, n, as,
1961  $ aa, lda )
1962  END IF
1963  IF( .NOT.packed )THEN
1964  isame( 7 ) = ldas.EQ.lda
1965  END IF
1966 *
1967 * If data was incorrectly changed, report and return.
1968 *
1969  same = .true.
1970  DO 30 i = 1, nargs
1971  same = same.AND.isame( i )
1972  IF( .NOT.isame( i ) )
1973  $ WRITE( nout, fmt = 9998 )i
1974  30 CONTINUE
1975  IF( .NOT.same )THEN
1976  fatal = .true.
1977  GO TO 120
1978  END IF
1979 *
1980  IF( .NOT.null )THEN
1981 *
1982 * Check the result column by column.
1983 *
1984  IF( incx.GT.0 )THEN
1985  DO 40 i = 1, n
1986  z( i ) = x( i )
1987  40 CONTINUE
1988  ELSE
1989  DO 50 i = 1, n
1990  z( i ) = x( n - i + 1 )
1991  50 CONTINUE
1992  END IF
1993  ja = 1
1994  DO 60 j = 1, n
1995  w( 1 ) = conjg( z( j ) )
1996  IF( upper )THEN
1997  jj = 1
1998  lj = j
1999  ELSE
2000  jj = j
2001  lj = n - j + 1
2002  END IF
2003  CALL cmvch( 'N', lj, 1, alpha, z( jj ), lj, w,
2004  $ 1, one, a( jj, j ), 1, yt, g,
2005  $ aa( ja ), eps, err, fatal, nout,
2006  $ .true. )
2007  IF( full )THEN
2008  IF( upper )THEN
2009  ja = ja + lda
2010  ELSE
2011  ja = ja + lda + 1
2012  END IF
2013  ELSE
2014  ja = ja + lj
2015  END IF
2016  errmax = max( errmax, err )
2017 * If got really bad answer, report and return.
2018  IF( fatal )
2019  $ GO TO 110
2020  60 CONTINUE
2021  ELSE
2022 * Avoid repeating tests if N.le.0.
2023  IF( n.LE.0 )
2024  $ GO TO 100
2025  END IF
2026 *
2027  70 CONTINUE
2028 *
2029  80 CONTINUE
2030 *
2031  90 CONTINUE
2032 *
2033  100 CONTINUE
2034 *
2035 * Report result.
2036 *
2037  IF( errmax.LT.thresh )THEN
2038  WRITE( nout, fmt = 9999 )sname, nc
2039  ELSE
2040  WRITE( nout, fmt = 9997 )sname, nc, errmax
2041  END IF
2042  GO TO 130
2043 *
2044  110 CONTINUE
2045  WRITE( nout, fmt = 9995 )j
2046 *
2047  120 CONTINUE
2048  WRITE( nout, fmt = 9996 )sname
2049  IF( full )THEN
2050  WRITE( nout, fmt = 9993 )nc, sname, uplo, n, ralpha, incx, lda
2051  ELSE IF( packed )THEN
2052  WRITE( nout, fmt = 9994 )nc, sname, uplo, n, ralpha, incx
2053  END IF
2054 *
2055  130 CONTINUE
2056  RETURN
2057 *
2058  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
2059  $ 'S)' )
2060  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2061  $ 'ANGED INCORRECTLY *******' )
2062  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2063  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2064  $ ' - SUSPECT *******' )
2065  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
2066  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2067  9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
2068  $ i2, ', AP) .' )
2069  9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
2070  $ i2, ', A,', i3, ') .' )
2071  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2072  $ '******' )
2073 *
2074 * End of CCHK5
2075 *
2076  END
2077  SUBROUTINE cchk6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
2078  $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
2079  $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
2080  $ Z )
2081 *
2082 * Tests CHER2 and CHPR2.
2083 *
2084 * Auxiliary routine for test program for Level 2 Blas.
2085 *
2086 * -- Written on 10-August-1987.
2087 * Richard Hanson, Sandia National Labs.
2088 * Jeremy Du Croz, NAG Central Office.
2089 *
2090 * .. Parameters ..
2091  COMPLEX zero, half, one
2092  parameter( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
2093  $ one = ( 1.0, 0.0 ) )
2094  REAL rzero
2095  parameter( rzero = 0.0 )
2096 * .. Scalar Arguments ..
2097  REAL eps, thresh
2098  INTEGER incmax, nalf, nidim, ninc, nmax, nout, ntra
2099  LOGICAL fatal, rewi, trace
2100  CHARACTER*6 sname
2101 * .. Array Arguments ..
2102  COMPLEX a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
2103  $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
2104  $ xx( nmax*incmax ), y( nmax ),
2105  $ ys( nmax*incmax ), yt( nmax ),
2106  $ yy( nmax*incmax ), z( nmax, 2 )
2107  REAL g( nmax )
2108  INTEGER idim( nidim ), inc( ninc )
2109 * .. Local Scalars ..
2110  COMPLEX alpha, als, transl
2111  REAL err, errmax
2112  INTEGER i, ia, ic, in, incx, incxs, incy, incys, ix,
2113  $ iy, j, ja, jj, laa, lda, ldas, lj, lx, ly, n,
2114  $ nargs, nc, ns
2115  LOGICAL full, null, packed, reset, same, upper
2116  CHARACTER*1 uplo, uplos
2117  CHARACTER*2 ich
2118 * .. Local Arrays ..
2119  COMPLEX w( 2 )
2120  LOGICAL isame( 13 )
2121 * .. External Functions ..
2122  LOGICAL lce, lceres
2123  EXTERNAL lce, lceres
2124 * .. External Subroutines ..
2125  EXTERNAL cher2, chpr2, cmake, cmvch
2126 * .. Intrinsic Functions ..
2127  INTRINSIC abs, conjg, max
2128 * .. Scalars in Common ..
2129  INTEGER infot, noutc
2130  LOGICAL lerr, ok
2131 * .. Common blocks ..
2132  COMMON /infoc/infot, noutc, ok, lerr
2133 * .. Data statements ..
2134  DATA ich/'UL'/
2135 * .. Executable Statements ..
2136  full = sname( 3: 3 ).EQ.'E'
2137  packed = sname( 3: 3 ).EQ.'P'
2138 * Define the number of arguments.
2139  IF( full )THEN
2140  nargs = 9
2141  ELSE IF( packed )THEN
2142  nargs = 8
2143  END IF
2144 *
2145  nc = 0
2146  reset = .true.
2147  errmax = rzero
2148 *
2149  DO 140 in = 1, nidim
2150  n = idim( in )
2151 * Set LDA to 1 more than minimum value if room.
2152  lda = n
2153  IF( lda.LT.nmax )
2154  $ lda = lda + 1
2155 * Skip tests if not enough room.
2156  IF( lda.GT.nmax )
2157  $ GO TO 140
2158  IF( packed )THEN
2159  laa = ( n*( n + 1 ) )/2
2160  ELSE
2161  laa = lda*n
2162  END IF
2163 *
2164  DO 130 ic = 1, 2
2165  uplo = ich( ic: ic )
2166  upper = uplo.EQ.'U'
2167 *
2168  DO 120 ix = 1, ninc
2169  incx = inc( ix )
2170  lx = abs( incx )*n
2171 *
2172 * Generate the vector X.
2173 *
2174  transl = half
2175  CALL cmake( 'GE', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
2176  $ 0, n - 1, reset, transl )
2177  IF( n.GT.1 )THEN
2178  x( n/2 ) = zero
2179  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
2180  END IF
2181 *
2182  DO 110 iy = 1, ninc
2183  incy = inc( iy )
2184  ly = abs( incy )*n
2185 *
2186 * Generate the vector Y.
2187 *
2188  transl = zero
2189  CALL cmake( 'GE', ' ', ' ', 1, n, y, 1, yy,
2190  $ abs( incy ), 0, n - 1, reset, transl )
2191  IF( n.GT.1 )THEN
2192  y( n/2 ) = zero
2193  yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
2194  END IF
2195 *
2196  DO 100 ia = 1, nalf
2197  alpha = alf( ia )
2198  null = n.LE.0.OR.alpha.EQ.zero
2199 *
2200 * Generate the matrix A.
2201 *
2202  transl = zero
2203  CALL cmake( sname( 2: 3 ), uplo, ' ', n, n, a,
2204  $ nmax, aa, lda, n - 1, n - 1, reset,
2205  $ transl )
2206 *
2207  nc = nc + 1
2208 *
2209 * Save every datum before calling the subroutine.
2210 *
2211  uplos = uplo
2212  ns = n
2213  als = alpha
2214  DO 10 i = 1, laa
2215  as( i ) = aa( i )
2216  10 CONTINUE
2217  ldas = lda
2218  DO 20 i = 1, lx
2219  xs( i ) = xx( i )
2220  20 CONTINUE
2221  incxs = incx
2222  DO 30 i = 1, ly
2223  ys( i ) = yy( i )
2224  30 CONTINUE
2225  incys = incy
2226 *
2227 * Call the subroutine.
2228 *
2229  IF( full )THEN
2230  IF( trace )
2231  $ WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
2232  $ alpha, incx, incy, lda
2233  IF( rewi )
2234  $ rewind ntra
2235  CALL cher2( uplo, n, alpha, xx, incx, yy, incy,
2236  $ aa, lda )
2237  ELSE IF( packed )THEN
2238  IF( trace )
2239  $ WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
2240  $ alpha, incx, incy
2241  IF( rewi )
2242  $ rewind ntra
2243  CALL chpr2( uplo, n, alpha, xx, incx, yy, incy,
2244  $ aa )
2245  END IF
2246 *
2247 * Check if error-exit was taken incorrectly.
2248 *
2249  IF( .NOT.ok )THEN
2250  WRITE( nout, fmt = 9992 )
2251  fatal = .true.
2252  GO TO 160
2253  END IF
2254 *
2255 * See what data changed inside subroutines.
2256 *
2257  isame( 1 ) = uplo.EQ.uplos
2258  isame( 2 ) = ns.EQ.n
2259  isame( 3 ) = als.EQ.alpha
2260  isame( 4 ) = lce( xs, xx, lx )
2261  isame( 5 ) = incxs.EQ.incx
2262  isame( 6 ) = lce( ys, yy, ly )
2263  isame( 7 ) = incys.EQ.incy
2264  IF( null )THEN
2265  isame( 8 ) = lce( as, aa, laa )
2266  ELSE
2267  isame( 8 ) = lceres( sname( 2: 3 ), uplo, n, n,
2268  $ as, aa, lda )
2269  END IF
2270  IF( .NOT.packed )THEN
2271  isame( 9 ) = ldas.EQ.lda
2272  END IF
2273 *
2274 * If data was incorrectly changed, report and return.
2275 *
2276  same = .true.
2277  DO 40 i = 1, nargs
2278  same = same.AND.isame( i )
2279  IF( .NOT.isame( i ) )
2280  $ WRITE( nout, fmt = 9998 )i
2281  40 CONTINUE
2282  IF( .NOT.same )THEN
2283  fatal = .true.
2284  GO TO 160
2285  END IF
2286 *
2287  IF( .NOT.null )THEN
2288 *
2289 * Check the result column by column.
2290 *
2291  IF( incx.GT.0 )THEN
2292  DO 50 i = 1, n
2293  z( i, 1 ) = x( i )
2294  50 CONTINUE
2295  ELSE
2296  DO 60 i = 1, n
2297  z( i, 1 ) = x( n - i + 1 )
2298  60 CONTINUE
2299  END IF
2300  IF( incy.GT.0 )THEN
2301  DO 70 i = 1, n
2302  z( i, 2 ) = y( i )
2303  70 CONTINUE
2304  ELSE
2305  DO 80 i = 1, n
2306  z( i, 2 ) = y( n - i + 1 )
2307  80 CONTINUE
2308  END IF
2309  ja = 1
2310  DO 90 j = 1, n
2311  w( 1 ) = alpha*conjg( z( j, 2 ) )
2312  w( 2 ) = conjg( alpha )*conjg( z( j, 1 ) )
2313  IF( upper )THEN
2314  jj = 1
2315  lj = j
2316  ELSE
2317  jj = j
2318  lj = n - j + 1
2319  END IF
2320  CALL cmvch( 'N', lj, 2, one, z( jj, 1 ),
2321  $ nmax, w, 1, one, a( jj, j ), 1,
2322  $ yt, g, aa( ja ), eps, err, fatal,
2323  $ nout, .true. )
2324  IF( full )THEN
2325  IF( upper )THEN
2326  ja = ja + lda
2327  ELSE
2328  ja = ja + lda + 1
2329  END IF
2330  ELSE
2331  ja = ja + lj
2332  END IF
2333  errmax = max( errmax, err )
2334 * If got really bad answer, report and return.
2335  IF( fatal )
2336  $ GO TO 150
2337  90 CONTINUE
2338  ELSE
2339 * Avoid repeating tests with N.le.0.
2340  IF( n.LE.0 )
2341  $ GO TO 140
2342  END IF
2343 *
2344  100 CONTINUE
2345 *
2346  110 CONTINUE
2347 *
2348  120 CONTINUE
2349 *
2350  130 CONTINUE
2351 *
2352  140 CONTINUE
2353 *
2354 * Report result.
2355 *
2356  IF( errmax.LT.thresh )THEN
2357  WRITE( nout, fmt = 9999 )sname, nc
2358  ELSE
2359  WRITE( nout, fmt = 9997 )sname, nc, errmax
2360  END IF
2361  GO TO 170
2362 *
2363  150 CONTINUE
2364  WRITE( nout, fmt = 9995 )j
2365 *
2366  160 CONTINUE
2367  WRITE( nout, fmt = 9996 )sname
2368  IF( full )THEN
2369  WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, incx,
2370  $ incy, lda
2371  ELSE IF( packed )THEN
2372  WRITE( nout, fmt = 9994 )nc, sname, uplo, n, alpha, incx, incy
2373  END IF
2374 *
2375  170 CONTINUE
2376  RETURN
2377 *
2378  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
2379  $ 'S)' )
2380  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2381  $ 'ANGED INCORRECTLY *******' )
2382  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2383  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2384  $ ' - SUSPECT *******' )
2385  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
2386  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2387  9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',(', f4.1, ',',
2388  $ f4.1, '), X,', i2, ', Y,', i2, ', AP) ',
2389  $ ' .' )
2390  9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',(', f4.1, ',',
2391  $ f4.1, '), X,', i2, ', Y,', i2, ', A,', i3, ') ',
2392  $ ' .' )
2393  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2394  $ '******' )
2395 *
2396 * End of CCHK6
2397 *
2398  END
2399  SUBROUTINE cchke( ISNUM, SRNAMT, NOUT )
2400 *
2401 * Tests the error exits from the Level 2 Blas.
2402 * Requires a special version of the error-handling routine XERBLA.
2403 * ALPHA, RALPHA, BETA, A, X and Y should not need to be defined.
2404 *
2405 * Auxiliary routine for test program for Level 2 Blas.
2406 *
2407 * -- Written on 10-August-1987.
2408 * Richard Hanson, Sandia National Labs.
2409 * Jeremy Du Croz, NAG Central Office.
2410 *
2411 * .. Scalar Arguments ..
2412  INTEGER isnum, nout
2413  CHARACTER*6 srnamt
2414 * .. Scalars in Common ..
2415  INTEGER infot, noutc
2416  LOGICAL lerr, ok
2417 * .. Local Scalars ..
2418  COMPLEX alpha, beta
2419  REAL ralpha
2420 * .. Local Arrays ..
2421  COMPLEX a( 1, 1 ), x( 1 ), y( 1 )
2422 * .. External Subroutines ..
2423  EXTERNAL cgbmv, cgemv, cgerc, cgeru, chbmv, chemv, cher,
2424  $ cher2, chkxer, chpmv, chpr, chpr2, ctbmv,
2425  $ ctbsv, ctpmv, ctpsv, ctrmv, ctrsv
2426 * .. Common blocks ..
2427  COMMON /infoc/infot, noutc, ok, lerr
2428 * .. Executable Statements ..
2429 * OK is set to .FALSE. by the special version of XERBLA or by CHKXER
2430 * if anything is wrong.
2431  ok = .true.
2432 * LERR is set to .TRUE. by the special version of XERBLA each time
2433 * it is called, and is then tested and re-set by CHKXER.
2434  lerr = .false.
2435  GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
2436  $ 90, 100, 110, 120, 130, 140, 150, 160,
2437  $ 170 )isnum
2438  10 infot = 1
2439  CALL cgemv( '/', 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2440  CALL chkxer( srnamt, infot, nout, lerr, ok )
2441  infot = 2
2442  CALL cgemv( 'N', -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2443  CALL chkxer( srnamt, infot, nout, lerr, ok )
2444  infot = 3
2445  CALL cgemv( 'N', 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2446  CALL chkxer( srnamt, infot, nout, lerr, ok )
2447  infot = 6
2448  CALL cgemv( 'N', 2, 0, alpha, a, 1, x, 1, beta, y, 1 )
2449  CALL chkxer( srnamt, infot, nout, lerr, ok )
2450  infot = 8
2451  CALL cgemv( 'N', 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2452  CALL chkxer( srnamt, infot, nout, lerr, ok )
2453  infot = 11
2454  CALL cgemv( 'N', 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2455  CALL chkxer( srnamt, infot, nout, lerr, ok )
2456  GO TO 180
2457  20 infot = 1
2458  CALL cgbmv( '/', 0, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2459  CALL chkxer( srnamt, infot, nout, lerr, ok )
2460  infot = 2
2461  CALL cgbmv( 'N', -1, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2462  CALL chkxer( srnamt, infot, nout, lerr, ok )
2463  infot = 3
2464  CALL cgbmv( 'N', 0, -1, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2465  CALL chkxer( srnamt, infot, nout, lerr, ok )
2466  infot = 4
2467  CALL cgbmv( 'N', 0, 0, -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2468  CALL chkxer( srnamt, infot, nout, lerr, ok )
2469  infot = 5
2470  CALL cgbmv( 'N', 2, 0, 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2471  CALL chkxer( srnamt, infot, nout, lerr, ok )
2472  infot = 8
2473  CALL cgbmv( 'N', 0, 0, 1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2474  CALL chkxer( srnamt, infot, nout, lerr, ok )
2475  infot = 10
2476  CALL cgbmv( 'N', 0, 0, 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2477  CALL chkxer( srnamt, infot, nout, lerr, ok )
2478  infot = 13
2479  CALL cgbmv( 'N', 0, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2480  CALL chkxer( srnamt, infot, nout, lerr, ok )
2481  GO TO 180
2482  30 infot = 1
2483  CALL chemv( '/', 0, alpha, a, 1, x, 1, beta, y, 1 )
2484  CALL chkxer( srnamt, infot, nout, lerr, ok )
2485  infot = 2
2486  CALL chemv( 'U', -1, alpha, a, 1, x, 1, beta, y, 1 )
2487  CALL chkxer( srnamt, infot, nout, lerr, ok )
2488  infot = 5
2489  CALL chemv( 'U', 2, alpha, a, 1, x, 1, beta, y, 1 )
2490  CALL chkxer( srnamt, infot, nout, lerr, ok )
2491  infot = 7
2492  CALL chemv( 'U', 0, alpha, a, 1, x, 0, beta, y, 1 )
2493  CALL chkxer( srnamt, infot, nout, lerr, ok )
2494  infot = 10
2495  CALL chemv( 'U', 0, alpha, a, 1, x, 1, beta, y, 0 )
2496  CALL chkxer( srnamt, infot, nout, lerr, ok )
2497  GO TO 180
2498  40 infot = 1
2499  CALL chbmv( '/', 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2500  CALL chkxer( srnamt, infot, nout, lerr, ok )
2501  infot = 2
2502  CALL chbmv( 'U', -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2503  CALL chkxer( srnamt, infot, nout, lerr, ok )
2504  infot = 3
2505  CALL chbmv( 'U', 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2506  CALL chkxer( srnamt, infot, nout, lerr, ok )
2507  infot = 6
2508  CALL chbmv( 'U', 0, 1, alpha, a, 1, x, 1, beta, y, 1 )
2509  CALL chkxer( srnamt, infot, nout, lerr, ok )
2510  infot = 8
2511  CALL chbmv( 'U', 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2512  CALL chkxer( srnamt, infot, nout, lerr, ok )
2513  infot = 11
2514  CALL chbmv( 'U', 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2515  CALL chkxer( srnamt, infot, nout, lerr, ok )
2516  GO TO 180
2517  50 infot = 1
2518  CALL chpmv( '/', 0, alpha, a, x, 1, beta, y, 1 )
2519  CALL chkxer( srnamt, infot, nout, lerr, ok )
2520  infot = 2
2521  CALL chpmv( 'U', -1, alpha, a, x, 1, beta, y, 1 )
2522  CALL chkxer( srnamt, infot, nout, lerr, ok )
2523  infot = 6
2524  CALL chpmv( 'U', 0, alpha, a, x, 0, beta, y, 1 )
2525  CALL chkxer( srnamt, infot, nout, lerr, ok )
2526  infot = 9
2527  CALL chpmv( 'U', 0, alpha, a, x, 1, beta, y, 0 )
2528  CALL chkxer( srnamt, infot, nout, lerr, ok )
2529  GO TO 180
2530  60 infot = 1
2531  CALL ctrmv( '/', 'N', 'N', 0, a, 1, x, 1 )
2532  CALL chkxer( srnamt, infot, nout, lerr, ok )
2533  infot = 2
2534  CALL ctrmv( 'U', '/', 'N', 0, a, 1, x, 1 )
2535  CALL chkxer( srnamt, infot, nout, lerr, ok )
2536  infot = 3
2537  CALL ctrmv( 'U', 'N', '/', 0, a, 1, x, 1 )
2538  CALL chkxer( srnamt, infot, nout, lerr, ok )
2539  infot = 4
2540  CALL ctrmv( 'U', 'N', 'N', -1, a, 1, x, 1 )
2541  CALL chkxer( srnamt, infot, nout, lerr, ok )
2542  infot = 6
2543  CALL ctrmv( 'U', 'N', 'N', 2, a, 1, x, 1 )
2544  CALL chkxer( srnamt, infot, nout, lerr, ok )
2545  infot = 8
2546  CALL ctrmv( 'U', 'N', 'N', 0, a, 1, x, 0 )
2547  CALL chkxer( srnamt, infot, nout, lerr, ok )
2548  GO TO 180
2549  70 infot = 1
2550  CALL ctbmv( '/', 'N', 'N', 0, 0, a, 1, x, 1 )
2551  CALL chkxer( srnamt, infot, nout, lerr, ok )
2552  infot = 2
2553  CALL ctbmv( 'U', '/', 'N', 0, 0, a, 1, x, 1 )
2554  CALL chkxer( srnamt, infot, nout, lerr, ok )
2555  infot = 3
2556  CALL ctbmv( 'U', 'N', '/', 0, 0, a, 1, x, 1 )
2557  CALL chkxer( srnamt, infot, nout, lerr, ok )
2558  infot = 4
2559  CALL ctbmv( 'U', 'N', 'N', -1, 0, a, 1, x, 1 )
2560  CALL chkxer( srnamt, infot, nout, lerr, ok )
2561  infot = 5
2562  CALL ctbmv( 'U', 'N', 'N', 0, -1, a, 1, x, 1 )
2563  CALL chkxer( srnamt, infot, nout, lerr, ok )
2564  infot = 7
2565  CALL ctbmv( 'U', 'N', 'N', 0, 1, a, 1, x, 1 )
2566  CALL chkxer( srnamt, infot, nout, lerr, ok )
2567  infot = 9
2568  CALL ctbmv( 'U', 'N', 'N', 0, 0, a, 1, x, 0 )
2569  CALL chkxer( srnamt, infot, nout, lerr, ok )
2570  GO TO 180
2571  80 infot = 1
2572  CALL ctpmv( '/', 'N', 'N', 0, a, x, 1 )
2573  CALL chkxer( srnamt, infot, nout, lerr, ok )
2574  infot = 2
2575  CALL ctpmv( 'U', '/', 'N', 0, a, x, 1 )
2576  CALL chkxer( srnamt, infot, nout, lerr, ok )
2577  infot = 3
2578  CALL ctpmv( 'U', 'N', '/', 0, a, x, 1 )
2579  CALL chkxer( srnamt, infot, nout, lerr, ok )
2580  infot = 4
2581  CALL ctpmv( 'U', 'N', 'N', -1, a, x, 1 )
2582  CALL chkxer( srnamt, infot, nout, lerr, ok )
2583  infot = 7
2584  CALL ctpmv( 'U', 'N', 'N', 0, a, x, 0 )
2585  CALL chkxer( srnamt, infot, nout, lerr, ok )
2586  GO TO 180
2587  90 infot = 1
2588  CALL ctrsv( '/', 'N', 'N', 0, a, 1, x, 1 )
2589  CALL chkxer( srnamt, infot, nout, lerr, ok )
2590  infot = 2
2591  CALL ctrsv( 'U', '/', 'N', 0, a, 1, x, 1 )
2592  CALL chkxer( srnamt, infot, nout, lerr, ok )
2593  infot = 3
2594  CALL ctrsv( 'U', 'N', '/', 0, a, 1, x, 1 )
2595  CALL chkxer( srnamt, infot, nout, lerr, ok )
2596  infot = 4
2597  CALL ctrsv( 'U', 'N', 'N', -1, a, 1, x, 1 )
2598  CALL chkxer( srnamt, infot, nout, lerr, ok )
2599  infot = 6
2600  CALL ctrsv( 'U', 'N', 'N', 2, a, 1, x, 1 )
2601  CALL chkxer( srnamt, infot, nout, lerr, ok )
2602  infot = 8
2603  CALL ctrsv( 'U', 'N', 'N', 0, a, 1, x, 0 )
2604  CALL chkxer( srnamt, infot, nout, lerr, ok )
2605  GO TO 180
2606  100 infot = 1
2607  CALL ctbsv( '/', 'N', 'N', 0, 0, a, 1, x, 1 )
2608  CALL chkxer( srnamt, infot, nout, lerr, ok )
2609  infot = 2
2610  CALL ctbsv( 'U', '/', 'N', 0, 0, a, 1, x, 1 )
2611  CALL chkxer( srnamt, infot, nout, lerr, ok )
2612  infot = 3
2613  CALL ctbsv( 'U', 'N', '/', 0, 0, a, 1, x, 1 )
2614  CALL chkxer( srnamt, infot, nout, lerr, ok )
2615  infot = 4
2616  CALL ctbsv( 'U', 'N', 'N', -1, 0, a, 1, x, 1 )
2617  CALL chkxer( srnamt, infot, nout, lerr, ok )
2618  infot = 5
2619  CALL ctbsv( 'U', 'N', 'N', 0, -1, a, 1, x, 1 )
2620  CALL chkxer( srnamt, infot, nout, lerr, ok )
2621  infot = 7
2622  CALL ctbsv( 'U', 'N', 'N', 0, 1, a, 1, x, 1 )
2623  CALL chkxer( srnamt, infot, nout, lerr, ok )
2624  infot = 9
2625  CALL ctbsv( 'U', 'N', 'N', 0, 0, a, 1, x, 0 )
2626  CALL chkxer( srnamt, infot, nout, lerr, ok )
2627  GO TO 180
2628  110 infot = 1
2629  CALL ctpsv( '/', 'N', 'N', 0, a, x, 1 )
2630  CALL chkxer( srnamt, infot, nout, lerr, ok )
2631  infot = 2
2632  CALL ctpsv( 'U', '/', 'N', 0, a, x, 1 )
2633  CALL chkxer( srnamt, infot, nout, lerr, ok )
2634  infot = 3
2635  CALL ctpsv( 'U', 'N', '/', 0, a, x, 1 )
2636  CALL chkxer( srnamt, infot, nout, lerr, ok )
2637  infot = 4
2638  CALL ctpsv( 'U', 'N', 'N', -1, a, x, 1 )
2639  CALL chkxer( srnamt, infot, nout, lerr, ok )
2640  infot = 7
2641  CALL ctpsv( 'U', 'N', 'N', 0, a, x, 0 )
2642  CALL chkxer( srnamt, infot, nout, lerr, ok )
2643  GO TO 180
2644  120 infot = 1
2645  CALL cgerc( -1, 0, alpha, x, 1, y, 1, a, 1 )
2646  CALL chkxer( srnamt, infot, nout, lerr, ok )
2647  infot = 2
2648  CALL cgerc( 0, -1, alpha, x, 1, y, 1, a, 1 )
2649  CALL chkxer( srnamt, infot, nout, lerr, ok )
2650  infot = 5
2651  CALL cgerc( 0, 0, alpha, x, 0, y, 1, a, 1 )
2652  CALL chkxer( srnamt, infot, nout, lerr, ok )
2653  infot = 7
2654  CALL cgerc( 0, 0, alpha, x, 1, y, 0, a, 1 )
2655  CALL chkxer( srnamt, infot, nout, lerr, ok )
2656  infot = 9
2657  CALL cgerc( 2, 0, alpha, x, 1, y, 1, a, 1 )
2658  CALL chkxer( srnamt, infot, nout, lerr, ok )
2659  GO TO 180
2660  130 infot = 1
2661  CALL cgeru( -1, 0, alpha, x, 1, y, 1, a, 1 )
2662  CALL chkxer( srnamt, infot, nout, lerr, ok )
2663  infot = 2
2664  CALL cgeru( 0, -1, alpha, x, 1, y, 1, a, 1 )
2665  CALL chkxer( srnamt, infot, nout, lerr, ok )
2666  infot = 5
2667  CALL cgeru( 0, 0, alpha, x, 0, y, 1, a, 1 )
2668  CALL chkxer( srnamt, infot, nout, lerr, ok )
2669  infot = 7
2670  CALL cgeru( 0, 0, alpha, x, 1, y, 0, a, 1 )
2671  CALL chkxer( srnamt, infot, nout, lerr, ok )
2672  infot = 9
2673  CALL cgeru( 2, 0, alpha, x, 1, y, 1, a, 1 )
2674  CALL chkxer( srnamt, infot, nout, lerr, ok )
2675  GO TO 180
2676  140 infot = 1
2677  CALL cher( '/', 0, ralpha, x, 1, a, 1 )
2678  CALL chkxer( srnamt, infot, nout, lerr, ok )
2679  infot = 2
2680  CALL cher( 'U', -1, ralpha, x, 1, a, 1 )
2681  CALL chkxer( srnamt, infot, nout, lerr, ok )
2682  infot = 5
2683  CALL cher( 'U', 0, ralpha, x, 0, a, 1 )
2684  CALL chkxer( srnamt, infot, nout, lerr, ok )
2685  infot = 7
2686  CALL cher( 'U', 2, ralpha, x, 1, a, 1 )
2687  CALL chkxer( srnamt, infot, nout, lerr, ok )
2688  GO TO 180
2689  150 infot = 1
2690  CALL chpr( '/', 0, ralpha, x, 1, a )
2691  CALL chkxer( srnamt, infot, nout, lerr, ok )
2692  infot = 2
2693  CALL chpr( 'U', -1, ralpha, x, 1, a )
2694  CALL chkxer( srnamt, infot, nout, lerr, ok )
2695  infot = 5
2696  CALL chpr( 'U', 0, ralpha, x, 0, a )
2697  CALL chkxer( srnamt, infot, nout, lerr, ok )
2698  GO TO 180
2699  160 infot = 1
2700  CALL cher2( '/', 0, alpha, x, 1, y, 1, a, 1 )
2701  CALL chkxer( srnamt, infot, nout, lerr, ok )
2702  infot = 2
2703  CALL cher2( 'U', -1, alpha, x, 1, y, 1, a, 1 )
2704  CALL chkxer( srnamt, infot, nout, lerr, ok )
2705  infot = 5
2706  CALL cher2( 'U', 0, alpha, x, 0, y, 1, a, 1 )
2707  CALL chkxer( srnamt, infot, nout, lerr, ok )
2708  infot = 7
2709  CALL cher2( 'U', 0, alpha, x, 1, y, 0, a, 1 )
2710  CALL chkxer( srnamt, infot, nout, lerr, ok )
2711  infot = 9
2712  CALL cher2( 'U', 2, alpha, x, 1, y, 1, a, 1 )
2713  CALL chkxer( srnamt, infot, nout, lerr, ok )
2714  GO TO 180
2715  170 infot = 1
2716  CALL chpr2( '/', 0, alpha, x, 1, y, 1, a )
2717  CALL chkxer( srnamt, infot, nout, lerr, ok )
2718  infot = 2
2719  CALL chpr2( 'U', -1, alpha, x, 1, y, 1, a )
2720  CALL chkxer( srnamt, infot, nout, lerr, ok )
2721  infot = 5
2722  CALL chpr2( 'U', 0, alpha, x, 0, y, 1, a )
2723  CALL chkxer( srnamt, infot, nout, lerr, ok )
2724  infot = 7
2725  CALL chpr2( 'U', 0, alpha, x, 1, y, 0, a )
2726  CALL chkxer( srnamt, infot, nout, lerr, ok )
2727 *
2728  180 IF( ok )THEN
2729  WRITE( nout, fmt = 9999 )srnamt
2730  ELSE
2731  WRITE( nout, fmt = 9998 )srnamt
2732  END IF
2733  RETURN
2734 *
2735  9999 FORMAT( ' ', a6, ' PASSED THE TESTS OF ERROR-EXITS' )
2736  9998 FORMAT( ' ******* ', a6, ' FAILED THE TESTS OF ERROR-EXITS *****',
2737  $ '**' )
2738 *
2739 * End of CCHKE
2740 *
2741  END
2742  SUBROUTINE cmake( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
2743  $ KU, RESET, TRANSL )
2744 *
2745 * Generates values for an M by N matrix A within the bandwidth
2746 * defined by KL and KU.
2747 * Stores the values in the array AA in the data structure required
2748 * by the routine, with unwanted elements set to rogue value.
2749 *
2750 * TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'.
2751 *
2752 * Auxiliary routine for test program for Level 2 Blas.
2753 *
2754 * -- Written on 10-August-1987.
2755 * Richard Hanson, Sandia National Labs.
2756 * Jeremy Du Croz, NAG Central Office.
2757 *
2758 * .. Parameters ..
2759  COMPLEX zero, one
2760  parameter( zero = ( 0.0, 0.0 ), one = ( 1.0, 0.0 ) )
2761  COMPLEX rogue
2762  parameter( rogue = ( -1.0e10, 1.0e10 ) )
2763  REAL rzero
2764  parameter( rzero = 0.0 )
2765  REAL rrogue
2766  parameter( rrogue = -1.0e10 )
2767 * .. Scalar Arguments ..
2768  COMPLEX transl
2769  INTEGER kl, ku, lda, m, n, nmax
2770  LOGICAL reset
2771  CHARACTER*1 diag, uplo
2772  CHARACTER*2 type
2773 * .. Array Arguments ..
2774  COMPLEX a( nmax, * ), aa( * )
2775 * .. Local Scalars ..
2776  INTEGER i, i1, i2, i3, ibeg, iend, ioff, j, jj, kk
2777  LOGICAL gen, lower, sym, tri, unit, upper
2778 * .. External Functions ..
2779  COMPLEX cbeg
2780  EXTERNAL cbeg
2781 * .. Intrinsic Functions ..
2782  INTRINSIC cmplx, conjg, max, min, real
2783 * .. Executable Statements ..
2784  gen = TYPE( 1: 1 ).EQ.'G'
2785  sym = TYPE( 1: 1 ).EQ.'H'
2786  tri = TYPE( 1: 1 ).EQ.'T'
2787  upper = ( sym.OR.tri ).AND.uplo.EQ.'U'
2788  lower = ( sym.OR.tri ).AND.uplo.EQ.'L'
2789  unit = tri.AND.diag.EQ.'U'
2790 *
2791 * Generate data in array A.
2792 *
2793  DO 20 j = 1, n
2794  DO 10 i = 1, m
2795  IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
2796  $ THEN
2797  IF( ( i.LE.j.AND.j - i.LE.ku ).OR.
2798  $ ( i.GE.j.AND.i - j.LE.kl ) )THEN
2799  a( i, j ) = cbeg( reset ) + transl
2800  ELSE
2801  a( i, j ) = zero
2802  END IF
2803  IF( i.NE.j )THEN
2804  IF( sym )THEN
2805  a( j, i ) = conjg( a( i, j ) )
2806  ELSE IF( tri )THEN
2807  a( j, i ) = zero
2808  END IF
2809  END IF
2810  END IF
2811  10 CONTINUE
2812  IF( sym )
2813  $ a( j, j ) = cmplx( REAL( A( J, J ) ), rzero )
2814  IF( tri )
2815  $ a( j, j ) = a( j, j ) + one
2816  IF( unit )
2817  $ a( j, j ) = one
2818  20 CONTINUE
2819 *
2820 * Store elements in array AS in data structure required by routine.
2821 *
2822  IF( type.EQ.'GE' )THEN
2823  DO 50 j = 1, n
2824  DO 30 i = 1, m
2825  aa( i + ( j - 1 )*lda ) = a( i, j )
2826  30 CONTINUE
2827  DO 40 i = m + 1, lda
2828  aa( i + ( j - 1 )*lda ) = rogue
2829  40 CONTINUE
2830  50 CONTINUE
2831  ELSE IF( type.EQ.'GB' )THEN
2832  DO 90 j = 1, n
2833  DO 60 i1 = 1, ku + 1 - j
2834  aa( i1 + ( j - 1 )*lda ) = rogue
2835  60 CONTINUE
2836  DO 70 i2 = i1, min( kl + ku + 1, ku + 1 + m - j )
2837  aa( i2 + ( j - 1 )*lda ) = a( i2 + j - ku - 1, j )
2838  70 CONTINUE
2839  DO 80 i3 = i2, lda
2840  aa( i3 + ( j - 1 )*lda ) = rogue
2841  80 CONTINUE
2842  90 CONTINUE
2843  ELSE IF( type.EQ.'HE'.OR.type.EQ.'TR' )THEN
2844  DO 130 j = 1, n
2845  IF( upper )THEN
2846  ibeg = 1
2847  IF( unit )THEN
2848  iend = j - 1
2849  ELSE
2850  iend = j
2851  END IF
2852  ELSE
2853  IF( unit )THEN
2854  ibeg = j + 1
2855  ELSE
2856  ibeg = j
2857  END IF
2858  iend = n
2859  END IF
2860  DO 100 i = 1, ibeg - 1
2861  aa( i + ( j - 1 )*lda ) = rogue
2862  100 CONTINUE
2863  DO 110 i = ibeg, iend
2864  aa( i + ( j - 1 )*lda ) = a( i, j )
2865  110 CONTINUE
2866  DO 120 i = iend + 1, lda
2867  aa( i + ( j - 1 )*lda ) = rogue
2868  120 CONTINUE
2869  IF( sym )THEN
2870  jj = j + ( j - 1 )*lda
2871  aa( jj ) = cmplx( REAL( AA( JJ ) ), rrogue )
2872  END IF
2873  130 CONTINUE
2874  ELSE IF( type.EQ.'HB'.OR.type.EQ.'TB' )THEN
2875  DO 170 j = 1, n
2876  IF( upper )THEN
2877  kk = kl + 1
2878  ibeg = max( 1, kl + 2 - j )
2879  IF( unit )THEN
2880  iend = kl
2881  ELSE
2882  iend = kl + 1
2883  END IF
2884  ELSE
2885  kk = 1
2886  IF( unit )THEN
2887  ibeg = 2
2888  ELSE
2889  ibeg = 1
2890  END IF
2891  iend = min( kl + 1, 1 + m - j )
2892  END IF
2893  DO 140 i = 1, ibeg - 1
2894  aa( i + ( j - 1 )*lda ) = rogue
2895  140 CONTINUE
2896  DO 150 i = ibeg, iend
2897  aa( i + ( j - 1 )*lda ) = a( i + j - kk, j )
2898  150 CONTINUE
2899  DO 160 i = iend + 1, lda
2900  aa( i + ( j - 1 )*lda ) = rogue
2901  160 CONTINUE
2902  IF( sym )THEN
2903  jj = kk + ( j - 1 )*lda
2904  aa( jj ) = cmplx( REAL( AA( JJ ) ), rrogue )
2905  END IF
2906  170 CONTINUE
2907  ELSE IF( type.EQ.'HP'.OR.type.EQ.'TP' )THEN
2908  ioff = 0
2909  DO 190 j = 1, n
2910  IF( upper )THEN
2911  ibeg = 1
2912  iend = j
2913  ELSE
2914  ibeg = j
2915  iend = n
2916  END IF
2917  DO 180 i = ibeg, iend
2918  ioff = ioff + 1
2919  aa( ioff ) = a( i, j )
2920  IF( i.EQ.j )THEN
2921  IF( unit )
2922  $ aa( ioff ) = rogue
2923  IF( sym )
2924  $ aa( ioff ) = cmplx( REAL( AA( IOFF ) ), rrogue )
2925  END IF
2926  180 CONTINUE
2927  190 CONTINUE
2928  END IF
2929  RETURN
2930 *
2931 * End of CMAKE
2932 *
2933  END
2934  SUBROUTINE cmvch( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
2935  $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
2936 *
2937 * Checks the results of the computational tests.
2938 *
2939 * Auxiliary routine for test program for Level 2 Blas.
2940 *
2941 * -- Written on 10-August-1987.
2942 * Richard Hanson, Sandia National Labs.
2943 * Jeremy Du Croz, NAG Central Office.
2944 *
2945 * .. Parameters ..
2946  COMPLEX zero
2947  parameter( zero = ( 0.0, 0.0 ) )
2948  REAL rzero, rone
2949  parameter( rzero = 0.0, rone = 1.0 )
2950 * .. Scalar Arguments ..
2951  COMPLEX alpha, beta
2952  REAL eps, err
2953  INTEGER incx, incy, m, n, nmax, nout
2954  LOGICAL fatal, mv
2955  CHARACTER*1 trans
2956 * .. Array Arguments ..
2957  COMPLEX a( nmax, * ), x( * ), y( * ), yt( * ), yy( * )
2958  REAL g( * )
2959 * .. Local Scalars ..
2960  COMPLEX c
2961  REAL erri
2962  INTEGER i, incxl, incyl, iy, j, jx, kx, ky, ml, nl
2963  LOGICAL ctran, tran
2964 * .. Intrinsic Functions ..
2965  INTRINSIC abs, aimag, conjg, max, REAL, sqrt
2966 * .. Statement Functions ..
2967  REAL abs1
2968 * .. Statement Function definitions ..
2969  abs1( c ) = abs( REAL( C ) ) + abs( aimag( c ) )
2970 * .. Executable Statements ..
2971  tran = trans.EQ.'T'
2972  ctran = trans.EQ.'C'
2973  IF( tran.OR.ctran )THEN
2974  ml = n
2975  nl = m
2976  ELSE
2977  ml = m
2978  nl = n
2979  END IF
2980  IF( incx.LT.0 )THEN
2981  kx = nl
2982  incxl = -1
2983  ELSE
2984  kx = 1
2985  incxl = 1
2986  END IF
2987  IF( incy.LT.0 )THEN
2988  ky = ml
2989  incyl = -1
2990  ELSE
2991  ky = 1
2992  incyl = 1
2993  END IF
2994 *
2995 * Compute expected result in YT using data in A, X and Y.
2996 * Compute gauges in G.
2997 *
2998  iy = ky
2999  DO 40 i = 1, ml
3000  yt( iy ) = zero
3001  g( iy ) = rzero
3002  jx = kx
3003  IF( tran )THEN
3004  DO 10 j = 1, nl
3005  yt( iy ) = yt( iy ) + a( j, i )*x( jx )
3006  g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
3007  jx = jx + incxl
3008  10 CONTINUE
3009  ELSE IF( ctran )THEN
3010  DO 20 j = 1, nl
3011  yt( iy ) = yt( iy ) + conjg( a( j, i ) )*x( jx )
3012  g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
3013  jx = jx + incxl
3014  20 CONTINUE
3015  ELSE
3016  DO 30 j = 1, nl
3017  yt( iy ) = yt( iy ) + a( i, j )*x( jx )
3018  g( iy ) = g( iy ) + abs1( a( i, j ) )*abs1( x( jx ) )
3019  jx = jx + incxl
3020  30 CONTINUE
3021  END IF
3022  yt( iy ) = alpha*yt( iy ) + beta*y( iy )
3023  g( iy ) = abs1( alpha )*g( iy ) + abs1( beta )*abs1( y( iy ) )
3024  iy = iy + incyl
3025  40 CONTINUE
3026 *
3027 * Compute the error ratio for this result.
3028 *
3029  err = zero
3030  DO 50 i = 1, ml
3031  erri = abs( yt( i ) - yy( 1 + ( i - 1 )*abs( incy ) ) )/eps
3032  IF( g( i ).NE.rzero )
3033  $ erri = erri/g( i )
3034  err = max( err, erri )
3035  IF( err*sqrt( eps ).GE.rone )
3036  $ GO TO 60
3037  50 CONTINUE
3038 * If the loop completes, all results are at least half accurate.
3039  GO TO 80
3040 *
3041 * Report fatal error.
3042 *
3043  60 fatal = .true.
3044  WRITE( nout, fmt = 9999 )
3045  DO 70 i = 1, ml
3046  IF( mv )THEN
3047  WRITE( nout, fmt = 9998 )i, yt( i ),
3048  $ yy( 1 + ( i - 1 )*abs( incy ) )
3049  ELSE
3050  WRITE( nout, fmt = 9998 )i,
3051  $ yy( 1 + ( i - 1 )*abs( incy ) ), yt( i )
3052  END IF
3053  70 CONTINUE
3054 *
3055  80 CONTINUE
3056  RETURN
3057 *
3058  9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3059  $ 'F ACCURATE *******', /' EXPECTED RE',
3060  $ 'SULT COMPUTED RESULT' )
3061  9998 FORMAT( 1x, i7, 2( ' (', g15.6, ',', g15.6, ')' ) )
3062 *
3063 * End of CMVCH
3064 *
3065  END
3066  LOGICAL FUNCTION lce( RI, RJ, LR )
3067 *
3068 * Tests if two arrays are identical.
3069 *
3070 * Auxiliary routine for test program for Level 2 Blas.
3071 *
3072 * -- Written on 10-August-1987.
3073 * Richard Hanson, Sandia National Labs.
3074 * Jeremy Du Croz, NAG Central Office.
3075 *
3076 * .. Scalar Arguments ..
3077  INTEGER lr
3078 * .. Array Arguments ..
3079  COMPLEX ri( * ), rj( * )
3080 * .. Local Scalars ..
3081  INTEGER i
3082 * .. Executable Statements ..
3083  DO 10 i = 1, lr
3084  IF( ri( i ).NE.rj( i ) )
3085  $ GO TO 20
3086  10 CONTINUE
3087  lce = .true.
3088  GO TO 30
3089  20 CONTINUE
3090  lce = .false.
3091  30 RETURN
3092 *
3093 * End of LCE
3094 *
3095  END
3096  LOGICAL FUNCTION lceres( TYPE, UPLO, M, N, AA, AS, LDA )
3097 *
3098 * Tests if selected elements in two arrays are equal.
3099 *
3100 * TYPE is 'GE', 'HE' or 'HP'.
3101 *
3102 * Auxiliary routine for test program for Level 2 Blas.
3103 *
3104 * -- Written on 10-August-1987.
3105 * Richard Hanson, Sandia National Labs.
3106 * Jeremy Du Croz, NAG Central Office.
3107 *
3108 * .. Scalar Arguments ..
3109  INTEGER lda, m, n
3110  CHARACTER*1 uplo
3111  CHARACTER*2 type
3112 * .. Array Arguments ..
3113  COMPLEX aa( lda, * ), as( lda, * )
3114 * .. Local Scalars ..
3115  INTEGER i, ibeg, iend, j
3116  LOGICAL upper
3117 * .. Executable Statements ..
3118  upper = uplo.EQ.'U'
3119  IF( type.EQ.'GE' )THEN
3120  DO 20 j = 1, n
3121  DO 10 i = m + 1, lda
3122  IF( aa( i, j ).NE.as( i, j ) )
3123  $ GO TO 70
3124  10 CONTINUE
3125  20 CONTINUE
3126  ELSE IF( type.EQ.'HE' )THEN
3127  DO 50 j = 1, n
3128  IF( upper )THEN
3129  ibeg = 1
3130  iend = j
3131  ELSE
3132  ibeg = j
3133  iend = n
3134  END IF
3135  DO 30 i = 1, ibeg - 1
3136  IF( aa( i, j ).NE.as( i, j ) )
3137  $ GO TO 70
3138  30 CONTINUE
3139  DO 40 i = iend + 1, lda
3140  IF( aa( i, j ).NE.as( i, j ) )
3141  $ GO TO 70
3142  40 CONTINUE
3143  50 CONTINUE
3144  END IF
3145 *
3146  lceres = .true.
3147  GO TO 80
3148  70 CONTINUE
3149  lceres = .false.
3150  80 RETURN
3151 *
3152 * End of LCERES
3153 *
3154  END
3155  COMPLEX FUNCTION cbeg( RESET )
3156 *
3157 * Generates complex numbers as pairs of random numbers uniformly
3158 * distributed between -0.5 and 0.5.
3159 *
3160 * Auxiliary routine for test program for Level 2 Blas.
3161 *
3162 * -- Written on 10-August-1987.
3163 * Richard Hanson, Sandia National Labs.
3164 * Jeremy Du Croz, NAG Central Office.
3165 *
3166 * .. Scalar Arguments ..
3167  LOGICAL reset
3168 * .. Local Scalars ..
3169  INTEGER i, ic, j, mi, mj
3170 * .. Save statement ..
3171  SAVE i, ic, j, mi, mj
3172 * .. Intrinsic Functions ..
3173  INTRINSIC cmplx
3174 * .. Executable Statements ..
3175  IF( reset )THEN
3176 * Initialize local variables.
3177  mi = 891
3178  mj = 457
3179  i = 7
3180  j = 7
3181  ic = 0
3182  reset = .false.
3183  END IF
3184 *
3185 * The sequence of values of I or J is bounded between 1 and 999.
3186 * If initial I or J = 1,2,3,6,7 or 9, the period will be 50.
3187 * If initial I or J = 4 or 8, the period will be 25.
3188 * If initial I or J = 5, the period will be 10.
3189 * IC is used to break up the period by skipping 1 value of I or J
3190 * in 6.
3191 *
3192  ic = ic + 1
3193  10 i = i*mi
3194  j = j*mj
3195  i = i - 1000*( i/1000 )
3196  j = j - 1000*( j/1000 )
3197  IF( ic.GE.5 )THEN
3198  ic = 0
3199  GO TO 10
3200  END IF
3201  cbeg = cmplx( ( i - 500 )/1001.0, ( j - 500 )/1001.0 )
3202  RETURN
3203 *
3204 * End of CBEG
3205 *
3206  END
3207  REAL FUNCTION sdiff( X, Y )
3208 *
3209 * Auxiliary routine for test program for Level 2 Blas.
3210 *
3211 * -- Written on 10-August-1987.
3212 * Richard Hanson, Sandia National Labs.
3213 *
3214 * .. Scalar Arguments ..
3215  REAL x, y
3216 * .. Executable Statements ..
3217  sdiff = x - y
3218  RETURN
3219 *
3220 * End of SDIFF
3221 *
3222  END
3223  SUBROUTINE chkxer( SRNAMT, INFOT, NOUT, LERR, OK )
3224 *
3225 * Tests whether XERBLA has detected an error when it should.
3226 *
3227 * Auxiliary routine for test program for Level 2 Blas.
3228 *
3229 * -- Written on 10-August-1987.
3230 * Richard Hanson, Sandia National Labs.
3231 * Jeremy Du Croz, NAG Central Office.
3232 *
3233 * .. Scalar Arguments ..
3234  INTEGER infot, nout
3235  LOGICAL lerr, ok
3236  CHARACTER*6 srnamt
3237 * .. Executable Statements ..
3238  IF( .NOT.lerr )THEN
3239  WRITE( nout, fmt = 9999 )infot, srnamt
3240  ok = .false.
3241  END IF
3242  lerr = .false.
3243  RETURN
3244 *
3245  9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', i2, ' NOT D',
3246  $ 'ETECTED BY ', a6, ' *****' )
3247 *
3248 * End of CHKXER
3249 *
3250  END
3251  SUBROUTINE cregr1( TRANS, M, N, LY, KL, KU, ALPHA, A, LDA, X,
3252  $ INCX, BETA, Y, INCY, YS )
3253 *
3254 * Input initialization for regression test.
3255 *
3256 * .. Scalar Arguments ..
3257  CHARACTER*1 trans
3258  INTEGER ly, m, n, kl, ku, lda, incx, incy
3259  COMPLEX alpha, beta
3260 * .. Array Arguments ..
3261  COMPLEX a(lda,*), x(*), y(*), ys(*)
3262 * .. Local Scalars ..
3263  INTEGER i
3264 * .. Intrinsic Functions ..
3265  INTRINSIC cmplx, real
3266 * .. Executable Statements ..
3267  trans = 'T'
3268  m = 0
3269  n = 5
3270  kl = 0
3271  ku = 0
3272  alpha = cmplx( 1.0 )
3273  lda = max( 1, m )
3274  incx = 1
3275  beta = cmplx( -0.7, -0.8 )
3276  incy = 1
3277  ly = abs( incy )*n
3278  DO 10 i = 1, ly
3279  y( i ) = cmplx( 42.0, REAL( I ) )
3280  ys( i ) = y( i )
3281  10 CONTINUE
3282  RETURN
3283  END
3284  SUBROUTINE xerbla( SRNAME, INFO )
3285 *
3286 * This is a special version of XERBLA to be used only as part of
3287 * the test program for testing error exits from the Level 2 BLAS
3288 * routines.
3289 *
3290 * XERBLA is an error handler for the Level 2 BLAS routines.
3291 *
3292 * It is called by the Level 2 BLAS routines if an input parameter is
3293 * invalid.
3294 *
3295 * Auxiliary routine for test program for Level 2 Blas.
3296 *
3297 * -- Written on 10-August-1987.
3298 * Richard Hanson, Sandia National Labs.
3299 * Jeremy Du Croz, NAG Central Office.
3300 *
3301 * .. Scalar Arguments ..
3302  INTEGER info
3303  CHARACTER*6 srname
3304 * .. Scalars in Common ..
3305  INTEGER infot, nout
3306  LOGICAL lerr, ok
3307  CHARACTER*6 srnamt
3308 * .. Common blocks ..
3309  COMMON /infoc/infot, nout, ok, lerr
3310  COMMON /srnamc/srnamt
3311 * .. Executable Statements ..
3312  lerr = .true.
3313  IF( info.NE.infot )THEN
3314  IF( infot.NE.0 )THEN
3315  WRITE( nout, fmt = 9999 )info, infot
3316  ELSE
3317  WRITE( nout, fmt = 9997 )info
3318  END IF
3319  ok = .false.
3320  END IF
3321  IF( srname.NE.srnamt )THEN
3322  WRITE( nout, fmt = 9998 )srname, srnamt
3323  ok = .false.
3324  END IF
3325  RETURN
3326 *
3327  9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', i6, ' INSTEAD',
3328  $ ' OF ', i2, ' *******' )
3329  9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', a6, ' INSTE',
3330  $ 'AD OF ', a6, ' *******' )
3331  9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', i6,
3332  $ ' *******' )
3333 *
3334 * End of XERBLA
3335 *
3336  END
ctpsv
subroutine ctpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
CTPSV
Definition: ctpsv.f:144
ctpmv
subroutine ctpmv(UPLO, TRANS, DIAG, N, AP, X, INCX)
CTPMV
Definition: ctpmv.f:142
cgemv
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
Definition: cgemv.f:158
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
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
chpr
subroutine chpr(UPLO, N, ALPHA, X, INCX, AP)
CHPR
Definition: chpr.f:130
cgeru
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU
Definition: cgeru.f:130
cgerc
subroutine cgerc(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERC
Definition: cgerc.f:130
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
chpr2
subroutine chpr2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP)
CHPR2
Definition: chpr2.f:145
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
cher
subroutine cher(UPLO, N, ALPHA, X, INCX, A, LDA)
CHER
Definition: cher.f:135
ctbmv
subroutine ctbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
CTBMV
Definition: ctbmv.f:186
chemv
subroutine chemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHEMV
Definition: chemv.f:154
chpmv
subroutine chpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
CHPMV
Definition: chpmv.f:149