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