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