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