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