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