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