source: pacpussensors/trunk/Vislab/lib3dv/eigen/blas/testing/dblat2.f@ 140

Last change on this file since 140 was 136, checked in by ldecherf, 8 years ago

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