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