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