source: pacpussensors/trunk/Vislab/lib3dv-1.2.0/lib3dv/eigen/blas/testing/cblat2.f

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

Doc
File size: 113.0 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.