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