LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
sblat2.f
Go to the documentation of this file.
1*> \brief \b SBLAT2
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 SBLAT2
12*
13*
14*> \par Purpose:
15* =============
16*>
17*> \verbatim
18*>
19*> Test program for the REAL 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*> 'sblat2.out' NAME OF SUMMARY OUTPUT FILE
27*> 6 UNIT NUMBER OF SUMMARY FILE
28*> 'SBLAT2.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 BETA
44*> SGEMV T PUT F FOR NO TEST. SAME COLUMNS.
45*> SGBMV T PUT F FOR NO TEST. SAME COLUMNS.
46*> SSYMV T PUT F FOR NO TEST. SAME COLUMNS.
47*> SSBMV T PUT F FOR NO TEST. SAME COLUMNS.
48*> SSPMV T PUT F FOR NO TEST. SAME COLUMNS.
49*> STRMV T PUT F FOR NO TEST. SAME COLUMNS.
50*> STBMV T PUT F FOR NO TEST. SAME COLUMNS.
51*> STPMV T PUT F FOR NO TEST. SAME COLUMNS.
52*> STRSV T PUT F FOR NO TEST. SAME COLUMNS.
53*> STBSV T PUT F FOR NO TEST. SAME COLUMNS.
54*> STPSV T PUT F FOR NO TEST. SAME COLUMNS.
55*> SGER T PUT F FOR NO TEST. SAME COLUMNS.
56*> SSYR T PUT F FOR NO TEST. SAME COLUMNS.
57*> SSPR T PUT F FOR NO TEST. SAME COLUMNS.
58*> SSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
59*> SSPR2 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 single_blas_testing
99*
100* =====================================================================
101 PROGRAM sblat2
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 REAL zero, one
115 parameter( zero = 0.0, one = 1.0 )
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 REAL 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 REAL 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 REAL sdiff
142 LOGICAL lse
143 EXTERNAL sdiff, lse
144* .. External Subroutines ..
145 EXTERNAL schk1, schk2, schk3, schk4, schk5, schk6,
146 $ schke, smvch
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/'SGEMV ', 'SGBMV ', 'SSYMV ', 'SSBMV ',
158 $ 'SSPMV ', 'STRMV ', 'STBMV ', 'STPMV ',
159 $ 'STRSV ', 'STBSV ', 'STPSV ', 'SGER ',
160 $ 'SSYR ', 'SSPR ', 'SSYR2 ', 'SSPR2 '/
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 SMVCH 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 SMVCH YT holds
298* the result computed by SMVCH.
299 trans = 'N'
300 CALL smvch( trans, n, n, one, a, nmax, x, 1, zero, y, 1, yt, g,
301 $ yy, eps, err, fatal, nout, .true. )
302 same = lse( 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 smvch( trans, n, n, one, a, nmax, x, -1, zero, y, -1, yt, g,
309 $ yy, eps, err, fatal, nout, .true. )
310 same = lse( 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 schke( 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 SGEMV, 01, and SGBMV, 02.
338 140 CALL schk1( 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 SSYMV, 03, SSBMV, 04, and SSPMV, 05.
344 150 CALL schk2( 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 STRMV, 06, STBMV, 07, STPMV, 08,
350* STRSV, 09, STBSV, 10, and STPSV, 11.
351 160 CALL schk3( 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 SGER, 12.
356 170 CALL schk4( 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 SSYR, 13, and SSPR, 14.
362 180 CALL schk5( 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 SSYR2, 15, and SSPR2, 16.
368 190 CALL schk6( 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, e9.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 REAL 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 SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
414 $ 'ATED WRONGLY.', /' SMVCH 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 SBLAT2
425*
426 END
427 SUBROUTINE schk1( 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 SGEMV and SGBMV.
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 REAL ZERO, HALF
442 PARAMETER ( ZERO = 0.0, half = 0.5 )
443* .. Scalar Arguments ..
444 REAL 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 REAL 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 REAL 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 LSE, LSERES
470 EXTERNAL lse, lseres
471* .. External Subroutines ..
472 EXTERNAL sgbmv, sgemv, smake, smvch, sregr1
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 smake( 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 smake( '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 smake( '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 sgemv( 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 sgbmv( 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 ) = lse( as, aa, laa )
647 isame( 6 ) = ldas.EQ.lda
648 isame( 7 ) = lse( xs, xx, lx )
649 isame( 8 ) = incxs.EQ.incx
650 isame( 9 ) = bls.EQ.beta
651 IF( null )THEN
652 isame( 10 ) = lse( ys, yy, ly )
653 ELSE
654 isame( 10 ) = lseres( '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 ) = lse( as, aa, laa )
664 isame( 8 ) = ldas.EQ.lda
665 isame( 9 ) = lse( xs, xx, lx )
666 isame( 10 ) = incxs.EQ.incx
667 isame( 11 ) = bls.EQ.beta
668 IF( null )THEN
669 isame( 12 ) = lse( ys, yy, ly )
670 ELSE
671 isame( 12 ) = lseres( '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 smvch( 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 sregr1( 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 sgemv( 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 sgbmv( trans, m, n, kl, ku, alpha, aa, lda, xx, incx,
746 $ beta, yy, incy )
747 END IF
748 nc = nc + 1
749 IF( .NOT.lse( 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 SCHK1
794*
795 END
796 SUBROUTINE schk2( 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 SSYMV, SSBMV and SSPMV.
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 REAL ZERO, HALF
811 PARAMETER ( ZERO = 0.0, half = 0.5 )
812* .. Scalar Arguments ..
813 REAL 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 REAL 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 REAL 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 LSE, LSERES
838 EXTERNAL lse, lseres
839* .. External Subroutines ..
840 EXTERNAL smake, smvch, ssbmv, sspmv, ssymv
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 smake( 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 smake( '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 smake( '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 ssymv( 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 ssbmv( 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 sspmv( 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 ) = lse( as, aa, laa )
1006 isame( 5 ) = ldas.EQ.lda
1007 isame( 6 ) = lse( xs, xx, lx )
1008 isame( 7 ) = incxs.EQ.incx
1009 isame( 8 ) = bls.EQ.beta
1010 IF( null )THEN
1011 isame( 9 ) = lse( ys, yy, ly )
1012 ELSE
1013 isame( 9 ) = lseres( '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 ) = lse( as, aa, laa )
1021 isame( 6 ) = ldas.EQ.lda
1022 isame( 7 ) = lse( xs, xx, lx )
1023 isame( 8 ) = incxs.EQ.incx
1024 isame( 9 ) = bls.EQ.beta
1025 IF( null )THEN
1026 isame( 10 ) = lse( ys, yy, ly )
1027 ELSE
1028 isame( 10 ) = lseres( '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 ) = lse( as, aa, laa )
1035 isame( 5 ) = lse( xs, xx, lx )
1036 isame( 6 ) = incxs.EQ.incx
1037 isame( 7 ) = bls.EQ.beta
1038 IF( null )THEN
1039 isame( 8 ) = lse( ys, yy, ly )
1040 ELSE
1041 isame( 8 ) = lseres( '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 smvch( '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 SCHK2
1137*
1138 END
1139 SUBROUTINE schk3( 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 STRMV, STBMV, STPMV, STRSV, STBSV and STPSV.
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 REAL ZERO, HALF, ONE
1153 PARAMETER ( ZERO = 0.0, half = 0.5, one = 1.0 )
1154* .. Scalar Arguments ..
1155 REAL EPS, THRESH
1156 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
1157 LOGICAL FATAL, REWI, TRACE
1158 CHARACTER*6 SNAME
1159* .. Array Arguments ..
1160 REAL 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 REAL 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 LSE, LSERES
1177 EXTERNAL lse, lseres
1178* .. External Subroutines ..
1179 EXTERNAL smake, smvch, stbmv, stbsv, stpmv, stpsv,
1180 $ strmv, strsv
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 SMVCH.
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 smake( 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 smake( '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 strmv( 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 stbmv( 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 stpmv( 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 strsv( 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 stbsv( 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 stpsv( 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 ) = lse( as, aa, laa )
1363 isame( 6 ) = ldas.EQ.lda
1364 IF( null )THEN
1365 isame( 7 ) = lse( xs, xx, lx )
1366 ELSE
1367 isame( 7 ) = lseres( '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 ) = lse( as, aa, laa )
1374 isame( 7 ) = ldas.EQ.lda
1375 IF( null )THEN
1376 isame( 8 ) = lse( xs, xx, lx )
1377 ELSE
1378 isame( 8 ) = lseres( '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 ) = lse( as, aa, laa )
1384 IF( null )THEN
1385 isame( 6 ) = lse( xs, xx, lx )
1386 ELSE
1387 isame( 6 ) = lseres( '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 smvch( 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 smvch( 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 SCHK3
1494*
1495 END
1496 SUBROUTINE schk4( 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 SGER.
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 REAL ZERO, HALF, ONE
1511 PARAMETER ( ZERO = 0.0, half = 0.5, one = 1.0 )
1512* .. Scalar Arguments ..
1513 REAL EPS, THRESH
1514 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1515 LOGICAL FATAL, REWI, TRACE
1516 CHARACTER*6 SNAME
1517* .. Array Arguments ..
1518 REAL 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 REAL 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 REAL W( 1 )
1532 LOGICAL ISAME( 13 )
1533* .. External Functions ..
1534 LOGICAL LSE, LSERES
1535 EXTERNAL LSE, LSERES
1536* .. External Subroutines ..
1537 EXTERNAL sger, smake, smvch
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 smake( '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 smake( '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 smake( 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 sger( 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 ) = lse( xs, xx, lx )
1654 isame( 5 ) = incxs.EQ.incx
1655 isame( 6 ) = lse( ys, yy, ly )
1656 isame( 7 ) = incys.EQ.incy
1657 IF( null )THEN
1658 isame( 8 ) = lse( as, aa, laa )
1659 ELSE
1660 isame( 8 ) = lseres( '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 smvch( '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 SCHK4
1755*
1756 END
1757 SUBROUTINE schk5( 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 SSYR and SSPR.
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 REAL ZERO, HALF, ONE
1772 PARAMETER ( ZERO = 0.0, half = 0.5, one = 1.0 )
1773* .. Scalar Arguments ..
1774 REAL EPS, THRESH
1775 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1776 LOGICAL FATAL, REWI, TRACE
1777 CHARACTER*6 SNAME
1778* .. Array Arguments ..
1779 REAL 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 REAL 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 REAL W( 1 )
1794 LOGICAL ISAME( 13 )
1795* .. External Functions ..
1796 LOGICAL LSE, LSERES
1797 EXTERNAL LSE, LSERES
1798* .. External Subroutines ..
1799 EXTERNAL smake, smvch, sspr, ssyr
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 smake( '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 smake( 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 ssyr( 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 sspr( 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 ) = lse( xs, xx, lx )
1914 isame( 5 ) = incxs.EQ.incx
1915 IF( null )THEN
1916 isame( 6 ) = lse( as, aa, laa )
1917 ELSE
1918 isame( 6 ) = lseres( 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 smvch( '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 SCHK5
2033*
2034 END
2035 SUBROUTINE schk6( 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 SSYR2 and SSPR2.
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 REAL ZERO, HALF, ONE
2050 PARAMETER ( ZERO = 0.0, half = 0.5, one = 1.0 )
2051* .. Scalar Arguments ..
2052 REAL EPS, THRESH
2053 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
2054 LOGICAL FATAL, REWI, TRACE
2055 CHARACTER*6 SNAME
2056* .. Array Arguments ..
2057 REAL 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 REAL 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 REAL W( 2 )
2073 LOGICAL ISAME( 13 )
2074* .. External Functions ..
2075 LOGICAL LSE, LSERES
2076 EXTERNAL LSE, LSERES
2077* .. External Subroutines ..
2078 EXTERNAL SMAKE, SMVCH, SSPR2, SSYR2
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 smake( '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 smake( '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 smake( 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 ssyr2( 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 sspr2( 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 ) = lse( xs, xx, lx )
2214 isame( 5 ) = incxs.EQ.incx
2215 isame( 6 ) = lse( ys, yy, ly )
2216 isame( 7 ) = incys.EQ.incy
2217 IF( null )THEN
2218 isame( 8 ) = lse( as, aa, laa )
2219 ELSE
2220 isame( 8 ) = lseres( 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 smvch( '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 SCHK6
2348*
2349 END
2350 SUBROUTINE schke( 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 REAL ALPHA, BETA
2370* .. Local Arrays ..
2371 REAL A( 1, 1 ), X( 1 ), Y( 1 )
2372* .. External Subroutines ..
2373 EXTERNAL CHKXER, SGBMV, SGEMV, SGER, SSBMV, SSPMV, SSPR,
2374 $ SSPR2, SSYMV, SSYR, SSYR2, STBMV, STBSV, STPMV,
2375 $ STPSV, STRMV, STRSV
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 sgemv( '/', 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2390 CALL chkxer( srnamt, infot, nout, lerr, ok )
2391 infot = 2
2392 CALL sgemv( 'N', -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2393 CALL chkxer( srnamt, infot, nout, lerr, ok )
2394 infot = 3
2395 CALL sgemv( 'N', 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2396 CALL chkxer( srnamt, infot, nout, lerr, ok )
2397 infot = 6
2398 CALL sgemv( 'N', 2, 0, alpha, a, 1, x, 1, beta, y, 1 )
2399 CALL chkxer( srnamt, infot, nout, lerr, ok )
2400 infot = 8
2401 CALL sgemv( 'N', 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2402 CALL chkxer( srnamt, infot, nout, lerr, ok )
2403 infot = 11
2404 CALL sgemv( '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 sgbmv( '/', 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 sgbmv( '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 sgbmv( '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 sgbmv( '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 sgbmv( '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 sgbmv( '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 sgbmv( '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 sgbmv( '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 ssymv( '/', 0, alpha, a, 1, x, 1, beta, y, 1 )
2434 CALL chkxer( srnamt, infot, nout, lerr, ok )
2435 infot = 2
2436 CALL ssymv( 'U', -1, alpha, a, 1, x, 1, beta, y, 1 )
2437 CALL chkxer( srnamt, infot, nout, lerr, ok )
2438 infot = 5
2439 CALL ssymv( 'U', 2, alpha, a, 1, x, 1, beta, y, 1 )
2440 CALL chkxer( srnamt, infot, nout, lerr, ok )
2441 infot = 7
2442 CALL ssymv( 'U', 0, alpha, a, 1, x, 0, beta, y, 1 )
2443 CALL chkxer( srnamt, infot, nout, lerr, ok )
2444 infot = 10
2445 CALL ssymv( '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 ssbmv( '/', 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2450 CALL chkxer( srnamt, infot, nout, lerr, ok )
2451 infot = 2
2452 CALL ssbmv( 'U', -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2453 CALL chkxer( srnamt, infot, nout, lerr, ok )
2454 infot = 3
2455 CALL ssbmv( 'U', 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2456 CALL chkxer( srnamt, infot, nout, lerr, ok )
2457 infot = 6
2458 CALL ssbmv( 'U', 0, 1, alpha, a, 1, x, 1, beta, y, 1 )
2459 CALL chkxer( srnamt, infot, nout, lerr, ok )
2460 infot = 8
2461 CALL ssbmv( 'U', 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2462 CALL chkxer( srnamt, infot, nout, lerr, ok )
2463 infot = 11
2464 CALL ssbmv( '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 sspmv( '/', 0, alpha, a, x, 1, beta, y, 1 )
2469 CALL chkxer( srnamt, infot, nout, lerr, ok )
2470 infot = 2
2471 CALL sspmv( 'U', -1, alpha, a, x, 1, beta, y, 1 )
2472 CALL chkxer( srnamt, infot, nout, lerr, ok )
2473 infot = 6
2474 CALL sspmv( 'U', 0, alpha, a, x, 0, beta, y, 1 )
2475 CALL chkxer( srnamt, infot, nout, lerr, ok )
2476 infot = 9
2477 CALL sspmv( '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 strmv( '/', 'N', 'N', 0, a, 1, x, 1 )
2482 CALL chkxer( srnamt, infot, nout, lerr, ok )
2483 infot = 2
2484 CALL strmv( 'U', '/', 'N', 0, a, 1, x, 1 )
2485 CALL chkxer( srnamt, infot, nout, lerr, ok )
2486 infot = 3
2487 CALL strmv( 'U', 'N', '/', 0, a, 1, x, 1 )
2488 CALL chkxer( srnamt, infot, nout, lerr, ok )
2489 infot = 4
2490 CALL strmv( 'U', 'N', 'N', -1, a, 1, x, 1 )
2491 CALL chkxer( srnamt, infot, nout, lerr, ok )
2492 infot = 6
2493 CALL strmv( 'U', 'N', 'N', 2, a, 1, x, 1 )
2494 CALL chkxer( srnamt, infot, nout, lerr, ok )
2495 infot = 8
2496 CALL strmv( '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 stbmv( '/', 'N', 'N', 0, 0, a, 1, x, 1 )
2501 CALL chkxer( srnamt, infot, nout, lerr, ok )
2502 infot = 2
2503 CALL stbmv( 'U', '/', 'N', 0, 0, a, 1, x, 1 )
2504 CALL chkxer( srnamt, infot, nout, lerr, ok )
2505 infot = 3
2506 CALL stbmv( 'U', 'N', '/', 0, 0, a, 1, x, 1 )
2507 CALL chkxer( srnamt, infot, nout, lerr, ok )
2508 infot = 4
2509 CALL stbmv( 'U', 'N', 'N', -1, 0, a, 1, x, 1 )
2510 CALL chkxer( srnamt, infot, nout, lerr, ok )
2511 infot = 5
2512 CALL stbmv( 'U', 'N', 'N', 0, -1, a, 1, x, 1 )
2513 CALL chkxer( srnamt, infot, nout, lerr, ok )
2514 infot = 7
2515 CALL stbmv( 'U', 'N', 'N', 0, 1, a, 1, x, 1 )
2516 CALL chkxer( srnamt, infot, nout, lerr, ok )
2517 infot = 9
2518 CALL stbmv( '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 stpmv( '/', 'N', 'N', 0, a, x, 1 )
2523 CALL chkxer( srnamt, infot, nout, lerr, ok )
2524 infot = 2
2525 CALL stpmv( 'U', '/', 'N', 0, a, x, 1 )
2526 CALL chkxer( srnamt, infot, nout, lerr, ok )
2527 infot = 3
2528 CALL stpmv( 'U', 'N', '/', 0, a, x, 1 )
2529 CALL chkxer( srnamt, infot, nout, lerr, ok )
2530 infot = 4
2531 CALL stpmv( 'U', 'N', 'N', -1, a, x, 1 )
2532 CALL chkxer( srnamt, infot, nout, lerr, ok )
2533 infot = 7
2534 CALL stpmv( '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 strsv( '/', 'N', 'N', 0, a, 1, x, 1 )
2539 CALL chkxer( srnamt, infot, nout, lerr, ok )
2540 infot = 2
2541 CALL strsv( 'U', '/', 'N', 0, a, 1, x, 1 )
2542 CALL chkxer( srnamt, infot, nout, lerr, ok )
2543 infot = 3
2544 CALL strsv( 'U', 'N', '/', 0, a, 1, x, 1 )
2545 CALL chkxer( srnamt, infot, nout, lerr, ok )
2546 infot = 4
2547 CALL strsv( 'U', 'N', 'N', -1, a, 1, x, 1 )
2548 CALL chkxer( srnamt, infot, nout, lerr, ok )
2549 infot = 6
2550 CALL strsv( 'U', 'N', 'N', 2, a, 1, x, 1 )
2551 CALL chkxer( srnamt, infot, nout, lerr, ok )
2552 infot = 8
2553 CALL strsv( '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 stbsv( '/', 'N', 'N', 0, 0, a, 1, x, 1 )
2558 CALL chkxer( srnamt, infot, nout, lerr, ok )
2559 infot = 2
2560 CALL stbsv( 'U', '/', 'N', 0, 0, a, 1, x, 1 )
2561 CALL chkxer( srnamt, infot, nout, lerr, ok )
2562 infot = 3
2563 CALL stbsv( 'U', 'N', '/', 0, 0, a, 1, x, 1 )
2564 CALL chkxer( srnamt, infot, nout, lerr, ok )
2565 infot = 4
2566 CALL stbsv( 'U', 'N', 'N', -1, 0, a, 1, x, 1 )
2567 CALL chkxer( srnamt, infot, nout, lerr, ok )
2568 infot = 5
2569 CALL stbsv( 'U', 'N', 'N', 0, -1, a, 1, x, 1 )
2570 CALL chkxer( srnamt, infot, nout, lerr, ok )
2571 infot = 7
2572 CALL stbsv( 'U', 'N', 'N', 0, 1, a, 1, x, 1 )
2573 CALL chkxer( srnamt, infot, nout, lerr, ok )
2574 infot = 9
2575 CALL stbsv( '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 stpsv( '/', 'N', 'N', 0, a, x, 1 )
2580 CALL chkxer( srnamt, infot, nout, lerr, ok )
2581 infot = 2
2582 CALL stpsv( 'U', '/', 'N', 0, a, x, 1 )
2583 CALL chkxer( srnamt, infot, nout, lerr, ok )
2584 infot = 3
2585 CALL stpsv( 'U', 'N', '/', 0, a, x, 1 )
2586 CALL chkxer( srnamt, infot, nout, lerr, ok )
2587 infot = 4
2588 CALL stpsv( 'U', 'N', 'N', -1, a, x, 1 )
2589 CALL chkxer( srnamt, infot, nout, lerr, ok )
2590 infot = 7
2591 CALL stpsv( '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 sger( -1, 0, alpha, x, 1, y, 1, a, 1 )
2596 CALL chkxer( srnamt, infot, nout, lerr, ok )
2597 infot = 2
2598 CALL sger( 0, -1, alpha, x, 1, y, 1, a, 1 )
2599 CALL chkxer( srnamt, infot, nout, lerr, ok )
2600 infot = 5
2601 CALL sger( 0, 0, alpha, x, 0, y, 1, a, 1 )
2602 CALL chkxer( srnamt, infot, nout, lerr, ok )
2603 infot = 7
2604 CALL sger( 0, 0, alpha, x, 1, y, 0, a, 1 )
2605 CALL chkxer( srnamt, infot, nout, lerr, ok )
2606 infot = 9
2607 CALL sger( 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 ssyr( '/', 0, alpha, x, 1, a, 1 )
2612 CALL chkxer( srnamt, infot, nout, lerr, ok )
2613 infot = 2
2614 CALL ssyr( 'U', -1, alpha, x, 1, a, 1 )
2615 CALL chkxer( srnamt, infot, nout, lerr, ok )
2616 infot = 5
2617 CALL ssyr( 'U', 0, alpha, x, 0, a, 1 )
2618 CALL chkxer( srnamt, infot, nout, lerr, ok )
2619 infot = 7
2620 CALL ssyr( '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 sspr( '/', 0, alpha, x, 1, a )
2625 CALL chkxer( srnamt, infot, nout, lerr, ok )
2626 infot = 2
2627 CALL sspr( 'U', -1, alpha, x, 1, a )
2628 CALL chkxer( srnamt, infot, nout, lerr, ok )
2629 infot = 5
2630 CALL sspr( 'U', 0, alpha, x, 0, a )
2631 CALL chkxer( srnamt, infot, nout, lerr, ok )
2632 GO TO 170
2633 150 infot = 1
2634 CALL ssyr2( '/', 0, alpha, x, 1, y, 1, a, 1 )
2635 CALL chkxer( srnamt, infot, nout, lerr, ok )
2636 infot = 2
2637 CALL ssyr2( 'U', -1, alpha, x, 1, y, 1, a, 1 )
2638 CALL chkxer( srnamt, infot, nout, lerr, ok )
2639 infot = 5
2640 CALL ssyr2( 'U', 0, alpha, x, 0, y, 1, a, 1 )
2641 CALL chkxer( srnamt, infot, nout, lerr, ok )
2642 infot = 7
2643 CALL ssyr2( 'U', 0, alpha, x, 1, y, 0, a, 1 )
2644 CALL chkxer( srnamt, infot, nout, lerr, ok )
2645 infot = 9
2646 CALL ssyr2( '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 sspr2( '/', 0, alpha, x, 1, y, 1, a )
2651 CALL chkxer( srnamt, infot, nout, lerr, ok )
2652 infot = 2
2653 CALL sspr2( 'U', -1, alpha, x, 1, y, 1, a )
2654 CALL chkxer( srnamt, infot, nout, lerr, ok )
2655 infot = 5
2656 CALL sspr2( 'U', 0, alpha, x, 0, y, 1, a )
2657 CALL chkxer( srnamt, infot, nout, lerr, ok )
2658 infot = 7
2659 CALL sspr2( '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 SCHKE
2674*
2675 END
2676 SUBROUTINE smake( 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 REAL ZERO, ONE
2694 parameter( zero = 0.0, one = 1.0 )
2695 REAL ROGUE
2696 PARAMETER ( ROGUE = -1.0e10 )
2697* .. Scalar Arguments ..
2698 REAL 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 REAL 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 REAL SBEG
2710 EXTERNAL SBEG
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 ) = sbeg( 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 SMAKE
2850*
2851 END
2852 SUBROUTINE smvch( 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 REAL ZERO, ONE
2865 parameter( zero = 0.0, one = 1.0 )
2866* .. Scalar Arguments ..
2867 REAL ALPHA, BETA, EPS, ERR
2868 INTEGER INCX, INCY, M, N, NMAX, NOUT
2869 LOGICAL FATAL, MV
2870 CHARACTER*1 TRANS
2871* .. Array Arguments ..
2872 REAL A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ),
2873 $ YY( * )
2874* .. Local Scalars ..
2875 REAL 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 SMVCH
2967*
2968 END
2969 LOGICAL FUNCTION lse( 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 REAL 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 lse = .true.
2991 GO TO 30
2992 20 CONTINUE
2993 lse = .false.
2994 30 RETURN
2995*
2996* End of LSE
2997*
2998 END
2999 LOGICAL FUNCTION lseres( 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 REAL 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 lseres = .true.
3050 GO TO 80
3051 70 CONTINUE
3052 lseres = .false.
3053 80 RETURN
3054*
3055* End of LSERES
3056*
3057 END
3058 REAL function sbeg( 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 real
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 sbeg = real( i - 500 )/1001.0
3099 RETURN
3100*
3101* End of SBEG
3102*
3103 END
3104 REAL function sdiff( 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 REAL x, y
3113* .. Executable Statements ..
3114 sdiff = x - y
3115 RETURN
3116*
3117* End of SDIFF
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 sregr1( 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 REAL ALPHA, BETA
3157* .. Array Arguments ..
3158 REAL A(LDA,*), X(*), Y(*), YS(*)
3159* .. Local Scalars ..
3160 INTEGER I
3161* .. Intrinsic Functions ..
3162 INTRINSIC real
3163* .. Executable Statements ..
3164 trans = 'T'
3165 m = 0
3166 n = 5
3167 kl = 0
3168 ku = 0
3169 alpha = 1.0
3170 lda = max( 1, m )
3171 incx = 1
3172 beta = -0.7
3173 incy = 1
3174 ly = abs( incy )*n
3175 DO 10 i = 1, ly
3176 y( i ) = 42.0 + real( 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
sdiff
real function sdiff(sa, sb)
Definition cblat1.f:701
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3224
sgbmv
subroutine sgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
SGBMV
Definition sgbmv.f:188
sgemv
subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
SGEMV
Definition sgemv.f:158
sger
subroutine sger(m, n, alpha, x, incx, y, incy, a, lda)
SGER
Definition sger.f:130
ssbmv
subroutine ssbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
SSBMV
Definition ssbmv.f:184
ssymv
subroutine ssymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
SSYMV
Definition ssymv.f:152
ssyr
subroutine ssyr(uplo, n, alpha, x, incx, a, lda)
SSYR
Definition ssyr.f:132
sspmv
subroutine sspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
SSPMV
Definition sspmv.f:147
sspr
subroutine sspr(uplo, n, alpha, x, incx, ap)
SSPR
Definition sspr.f:127
stbmv
subroutine stbmv(uplo, trans, diag, n, k, a, lda, x, incx)
STBMV
Definition stbmv.f:186
stbsv
subroutine stbsv(uplo, trans, diag, n, k, a, lda, x, incx)
STBSV
Definition stbsv.f:189
stpmv
subroutine stpmv(uplo, trans, diag, n, ap, x, incx)
STPMV
Definition stpmv.f:142
stpsv
subroutine stpsv(uplo, trans, diag, n, ap, x, incx)
STPSV
Definition stpsv.f:144
strmv
subroutine strmv(uplo, trans, diag, n, a, lda, x, incx)
STRMV
Definition strmv.f:147
strsv
subroutine strsv(uplo, trans, diag, n, a, lda, x, incx)
STRSV
Definition strsv.f:149
schk6
subroutine schk6(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 sblat2.f:2039
schk3
subroutine schk3(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 sblat2.f:1142
sregr1
subroutine sregr1(trans, m, n, ly, kl, ku, alpha, a, lda, x, incx, beta, y, incy, ys)
Definition sblat2.f:3150
schk4
subroutine schk4(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 sblat2.f:1500
sblat2
program sblat2
SBLAT2
Definition sblat2.f:101
schke
subroutine schke(isnum, srnamt, nout)
Definition sblat2.f:2351
smvch
subroutine smvch(trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, err, fatal, nout, mv)
Definition sblat2.f:2854
lseres
logical function lseres(type, uplo, m, n, aa, as, lda)
Definition sblat2.f:3000
schk2
subroutine schk2(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 sblat2.f:800
schk1
subroutine schk1(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 sblat2.f:431
schk5
subroutine schk5(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 sblat2.f:1761
sbeg
real function sbeg(reset)
Definition sblat2.f:3059
smake
subroutine smake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition sblat2.f:2678
lse
logical function lse(ri, rj, lr)
Definition sblat2.f:2970