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