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