LAPACK  3.11.0
LAPACK: Linear Algebra PACKage
c_dblat2.f
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:130