OpenRadioss 2025.1.11
OpenRadioss project
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
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* Report result.
738*
739 IF( errmax.LT.thresh )THEN
740 WRITE( nout, fmt = 9999 )sname, nc
741 ELSE
742 WRITE( nout, fmt = 9997 )sname, nc, errmax
743 END IF
744 GO TO 140
745*
746 130 CONTINUE
747 WRITE( nout, fmt = 9996 )sname
748 IF( full )THEN
749 WRITE( nout, fmt = 9994 )nc, sname, trans, m, n, alpha, lda,
750 $ incx, beta, incy
751 ELSE IF( banded )THEN
752 WRITE( nout, fmt = 9995 )nc, sname, trans, m, n, kl, ku,
753 $ alpha, lda, incx, beta, incy
754 END IF
755*
756 140 CONTINUE
757 RETURN
758*
759 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
760 $ 'S)' )
761 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
762 $ 'ANGED INCORRECTLY *******' )
763 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
764 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
765 $ ' - SUSPECT *******' )
766 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
767 9995 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', 4( i3, ',' ), '(',
768 $ f4.1, ',', f4.1, '), A,', i3, ', X,', i2, ',(', f4.1, ',',
769 $ f4.1, '), Y,', i2, ') .' )
770 9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', 2( i3, ',' ), '(',
771 $ f4.1, ',', f4.1, '), A,', i3, ', X,', i2, ',(', f4.1, ',',
772 $ f4.1, '), Y,', i2, ') .' )
773 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
774 $ '******' )
775*
776* End of CCHK1
777*
778 END
779 SUBROUTINE cchk2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
780 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
781 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
782 $ XS, Y, YY, YS, YT, G )
783*
784* Tests CHEMV, CHBMV and CHPMV.
785*
786* Auxiliary routine for test program for Level 2 Blas.
787*
788* -- Written on 10-August-1987.
789* Richard Hanson, Sandia National Labs.
790* Jeremy Du Croz, NAG Central Office.
791*
792* .. Parameters ..
793 COMPLEX ZERO, HALF
794 PARAMETER ( ZERO = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ) )
795 REAL RZERO
796 PARAMETER ( RZERO = 0.0 )
797* .. Scalar Arguments ..
798 real eps, thresh
799 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
800 $ nout, ntra
801 LOGICAL FATAL, REWI, TRACE
802 CHARACTER*6 SNAME
803* .. Array Arguments ..
804 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
805 $ as( nmax*nmax ), bet( nbet ), x( nmax ),
806 $ xs( nmax*incmax ), xx( nmax*incmax ),
807 $ y( nmax ), ys( nmax*incmax ), yt( nmax ),
808 $ yy( nmax*incmax )
809 REAL G( NMAX )
810 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
811* .. Local Scalars ..
812 COMPLEX ALPHA, ALS, BETA, BLS, TRANSL
813 REAL ERR, ERRMAX
814 INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
815 $ incys, ix, iy, k, ks, laa, lda, ldas, lx, ly,
816 $ n, nargs, nc, nk, ns
817 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
818 CHARACTER*1 UPLO, UPLOS
819 CHARACTER*2 ICH
820* .. Local Arrays ..
821 LOGICAL ISAME( 13 )
822* .. External Functions ..
823 LOGICAL LCE, LCERES
824 EXTERNAL lce, lceres
825* .. External Subroutines ..
826 EXTERNAL chbmv, chemv, chpmv, cmake, cmvch
827* .. Intrinsic Functions ..
828 INTRINSIC abs, max
829* .. Scalars in Common ..
830 INTEGER INFOT, NOUTC
831 LOGICAL LERR, OK
832* .. Common blocks ..
833 COMMON /infoc/infot, noutc, ok, lerr
834* .. Data statements ..
835 DATA ich/'UL'/
836* .. Executable Statements ..
837 full = sname( 3: 3 ).EQ.'E'
838 banded = sname( 3: 3 ).EQ.'B'
839 packed = sname( 3: 3 ).EQ.'P'
840* Define the number of arguments.
841 IF( full )THEN
842 nargs = 10
843 ELSE IF( banded )THEN
844 nargs = 11
845 ELSE IF( packed )THEN
846 nargs = 9
847 END IF
848*
849 nc = 0
850 reset = .true.
851 errmax = rzero
852*
853 DO 110 in = 1, nidim
854 n = idim( in )
855*
856 IF( banded )THEN
857 nk = nkb
858 ELSE
859 nk = 1
860 END IF
861 DO 100 ik = 1, nk
862 IF( banded )THEN
863 k = kb( ik )
864 ELSE
865 k = n - 1
866 END IF
867* Set LDA to 1 more than minimum value if room.
868 IF( banded )THEN
869 lda = k + 1
870 ELSE
871 lda = n
872 END IF
873 IF( lda.LT.nmax )
874 $ lda = lda + 1
875* Skip tests if not enough room.
876 IF( lda.GT.nmax )
877 $ GO TO 100
878 IF( packed )THEN
879 laa = ( n*( n + 1 ) )/2
880 ELSE
881 laa = lda*n
882 END IF
883 null = n.LE.0
884*
885 DO 90 ic = 1, 2
886 uplo = ich( ic: ic )
887*
888* Generate the matrix A.
889*
890 transl = zero
891 CALL cmake( sname( 2: 3 ), uplo, ' ', n, n, a, nmax, aa,
892 $ lda, k, k, reset, transl )
893*
894 DO 80 ix = 1, ninc
895 incx = inc( ix )
896 lx = abs( incx )*n
897*
898* Generate the vector X.
899*
900 transl = half
901 CALL cmake( 'GE', ' ', ' ', 1, n, x, 1, xx,
902 $ abs( incx ), 0, n - 1, reset, transl )
903 IF( n.GT.1 )THEN
904 x( n/2 ) = zero
905 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
906 END IF
907*
908 DO 70 iy = 1, ninc
909 incy = inc( iy )
910 ly = abs( incy )*n
911*
912 DO 60 ia = 1, nalf
913 alpha = alf( ia )
914*
915 DO 50 ib = 1, nbet
916 beta = bet( ib )
917*
918* Generate the vector Y.
919*
920 transl = zero
921 CALL cmake( 'GE', ' ', ' ', 1, n, y, 1, yy,
922 $ abs( incy ), 0, n - 1, reset,
923 $ transl )
924*
925 nc = nc + 1
926*
927* Save every datum before calling the
928* subroutine.
929*
930 uplos = uplo
931 ns = n
932 ks = k
933 als = alpha
934 DO 10 i = 1, laa
935 as( i ) = aa( i )
936 10 CONTINUE
937 ldas = lda
938 DO 20 i = 1, lx
939 xs( i ) = xx( i )
940 20 CONTINUE
941 incxs = incx
942 bls = beta
943 DO 30 i = 1, ly
944 ys( i ) = yy( i )
945 30 CONTINUE
946 incys = incy
947*
948* Call the subroutine.
949*
950 IF( full )THEN
951 IF( trace )
952 $ WRITE( ntra, fmt = 9993 )nc, sname,
953 $ uplo, n, alpha, lda, incx, beta, incy
954 IF( rewi )
955 $ rewind ntra
956 CALL chemv( uplo, n, alpha, aa, lda, xx,
957 $ incx, beta, yy, incy )
958 ELSE IF( banded )THEN
959 IF( trace )
960 $ WRITE( ntra, fmt = 9994 )nc, sname,
961 $ uplo, n, k, alpha, lda, incx, beta,
962 $ incy
963 IF( rewi )
964 $ rewind ntra
965 CALL chbmv( uplo, n, k, alpha, aa, lda,
966 $ xx, incx, beta, yy, incy )
967 ELSE IF( packed )THEN
968 IF( trace )
969 $ WRITE( ntra, fmt = 9995 )nc, sname,
970 $ uplo, n, alpha, incx, beta, incy
971 IF( rewi )
972 $ rewind ntra
973 CALL chpmv( uplo, n, alpha, aa, xx, incx,
974 $ beta, yy, incy )
975 END IF
976*
977* Check if error-exit was taken incorrectly.
978*
979 IF( .NOT.ok )THEN
980 WRITE( nout, fmt = 9992 )
981 fatal = .true.
982 GO TO 120
983 END IF
984*
985* See what data changed inside subroutines.
986*
987 isame( 1 ) = uplo.EQ.uplos
988 isame( 2 ) = ns.EQ.n
989 IF( full )THEN
990 isame( 3 ) = als.EQ.alpha
991 isame( 4 ) = lce( as, aa, laa )
992 isame( 5 ) = ldas.EQ.lda
993 isame( 6 ) = lce( xs, xx, lx )
994 isame( 7 ) = incxs.EQ.incx
995 isame( 8 ) = bls.EQ.beta
996 IF( null )THEN
997 isame( 9 ) = lce( ys, yy, ly )
998 ELSE
999 isame( 9 ) = lceres( 'GE', ' ', 1, n,
1000 $ ys, yy, abs( incy ) )
1001 END IF
1002 isame( 10 ) = incys.EQ.incy
1003 ELSE IF( banded )THEN
1004 isame( 3 ) = ks.EQ.k
1005 isame( 4 ) = als.EQ.alpha
1006 isame( 5 ) = lce( as, aa, laa )
1007 isame( 6 ) = ldas.EQ.lda
1008 isame( 7 ) = lce( xs, xx, lx )
1009 isame( 8 ) = incxs.EQ.incx
1010 isame( 9 ) = bls.EQ.beta
1011 IF( null )THEN
1012 isame( 10 ) = lce( ys, yy, ly )
1013 ELSE
1014 isame( 10 ) = lceres( 'GE', ' ', 1, n,
1015 $ ys, yy, abs( incy ) )
1016 END IF
1017 isame( 11 ) = incys.EQ.incy
1018 ELSE IF( packed )THEN
1019 isame( 3 ) = als.EQ.alpha
1020 isame( 4 ) = lce( as, aa, laa )
1021 isame( 5 ) = lce( xs, xx, lx )
1022 isame( 6 ) = incxs.EQ.incx
1023 isame( 7 ) = bls.EQ.beta
1024 IF( null )THEN
1025 isame( 8 ) = lce( ys, yy, ly )
1026 ELSE
1027 isame( 8 ) = lceres( 'GE', ' ', 1, n,
1028 $ ys, yy, abs( incy ) )
1029 END IF
1030 isame( 9 ) = incys.EQ.incy
1031 END IF
1032*
1033* If data was incorrectly changed, report and
1034* return.
1035*
1036 same = .true.
1037 DO 40 i = 1, nargs
1038 same = same.AND.isame( i )
1039 IF( .NOT.isame( i ) )
1040 $ WRITE( nout, fmt = 9998 )i
1041 40 CONTINUE
1042 IF( .NOT.same )THEN
1043 fatal = .true.
1044 GO TO 120
1045 END IF
1046*
1047 IF( .NOT.null )THEN
1048*
1049* Check the result.
1050*
1051 CALL cmvch( 'n', N, N, ALPHA, A, NMAX, X,
1052 $ INCX, BETA, Y, INCY, YT, G,
1053 $ YY, EPS, ERR, FATAL, NOUT,
1054 $ .TRUE. )
1055 ERRMAX = MAX( ERRMAX, ERR )
1056* If got really bad answer, report and
1057* return.
1058 IF( FATAL )
1059 $ GO TO 120
1060 ELSE
1061* Avoid repeating tests with N.le.0
1062 GO TO 110
1063 END IF
1064*
1065 50 CONTINUE
1066*
1067 60 CONTINUE
1068*
1069 70 CONTINUE
1070*
1071 80 CONTINUE
1072*
1073 90 CONTINUE
1074*
1075 100 CONTINUE
1076*
1077 110 CONTINUE
1078*
1079* Report result.
1080*
1081.LT. IF( ERRMAXTHRESH )THEN
1082 WRITE( NOUT, FMT = 9999 )SNAME, NC
1083 ELSE
1084 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1085 END IF
1086 GO TO 130
1087*
1088 120 CONTINUE
1089 WRITE( NOUT, FMT = 9996 )SNAME
1090 IF( FULL )THEN
1091 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX,
1092 $ BETA, INCY
1093 ELSE IF( BANDED )THEN
1094 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA,
1095 $ INCX, BETA, INCY
1096 ELSE IF( PACKED )THEN
1097 WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX,
1098 $ BETA, INCY
1099 END IF
1100*
1101 130 CONTINUE
1102 RETURN
1103*
1104 9999 FORMAT( ' ', A6, ' passed the computational tests(', I6, ' call',
1105 $ 'S)' )
1106 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1107 $ 'ANGED INCORRECTLY *******' )
1108 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1109 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1110 $ ' - SUSPECT *******' )
1111 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1112 9995 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',(', F4.1, ',',
1113 $ F4.1, '), ap, x,', I2, ',(', F4.1, ',', F4.1, '), y,', I2,
1114 $ ') .' )
1115 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(',
1116 $ F4.1, ',', F4.1, '), a,', I3, ', x,', I2, ',(', F4.1, ',',
1117 $ F4.1, '), y,', I2, ') .' )
1118 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
1119 $ F4.1, '), a,', I3, ', x,', I2, ',(', F4.1, ',', F4.1, '), ',
1120 $ 'y,', I2, ') .' )
1121 9992 FORMAT( ' ******* fatal error - error-EXIT taken on valid CALL *',
1122 $ '******' )
1123*
1124* End of CCHK2
1125*
1126 END
1127 SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1128 $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
1129 $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z )
1130*
1131* Tests CTRMV, CTBMV, CTPMV, CTRSV, CTBSV and CTPSV.
1132*
1133* Auxiliary routine for test program for Level 2 Blas.
1134*
1135* -- Written on 10-August-1987.
1136* Richard Hanson, Sandia National Labs.
1137* Jeremy Du Croz, NAG Central Office.
1138*
1139* .. Parameters ..
1140 COMPLEX ZERO, HALF, ONE
1141 PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ),
1142 $ ONE = ( 1.0, 0.0 ) )
1143 REAL RZERO
1144 PARAMETER ( RZERO = 0.0 )
1145* .. Scalar Arguments ..
1146 REAL EPS, THRESH
1147 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
1148 LOGICAL FATAL, REWI, TRACE
1149 CHARACTER*6 SNAME
1150* .. Array Arguments ..
1151 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ),
1152 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
1153 $ XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX )
1154 REAL G( NMAX )
1155 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
1156* .. Local Scalars ..
1157 COMPLEX TRANSL
1158 REAL ERR, ERRMAX
1159 INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
1160 $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
1161 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
1162 CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
1163 CHARACTER*2 ICHD, ICHU
1164 CHARACTER*3 ICHT
1165* .. Local Arrays ..
1166 LOGICAL ISAME( 13 )
1167* .. External Functions ..
1168 LOGICAL LCE, LCERES
1169 EXTERNAL LCE, LCERES
1170* .. External Subroutines ..
1171 EXTERNAL CMAKE, CMVCH, CTBMV, CTBSV, CTPMV, CTPSV,
1172 $ CTRMV, CTRSV
1173* .. Intrinsic Functions ..
1174 INTRINSIC ABS, MAX
1175* .. Scalars in Common ..
1176 INTEGER INFOT, NOUTC
1177 LOGICAL LERR, OK
1178* .. Common blocks ..
1179 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1180* .. Data statements ..
1181 DATA ICHU/'ul'/, ICHT/'ntc'/, ICHD/'un'/
1182* .. Executable Statements ..
1183.EQ. FULL = SNAME( 3: 3 )'r'
1184.EQ. BANDED = SNAME( 3: 3 )'b'
1185.EQ. PACKED = SNAME( 3: 3 )'p'
1186* Define the number of arguments.
1187 IF( FULL )THEN
1188 NARGS = 8
1189 ELSE IF( BANDED )THEN
1190 NARGS = 9
1191 ELSE IF( PACKED )THEN
1192 NARGS = 7
1193 END IF
1194*
1195 NC = 0
1196 RESET = .TRUE.
1197 ERRMAX = RZERO
1198* Set up zero vector for CMVCH.
1199 DO 10 I = 1, NMAX
1200 Z( I ) = ZERO
1201 10 CONTINUE
1202*
1203 DO 110 IN = 1, NIDIM
1204 N = IDIM( IN )
1205*
1206 IF( BANDED )THEN
1207 NK = NKB
1208 ELSE
1209 NK = 1
1210 END IF
1211 DO 100 IK = 1, NK
1212 IF( BANDED )THEN
1213 K = KB( IK )
1214 ELSE
1215 K = N - 1
1216 END IF
1217* Set LDA to 1 more than minimum value if room.
1218 IF( BANDED )THEN
1219 LDA = K + 1
1220 ELSE
1221 LDA = N
1222 END IF
1223.LT. IF( LDANMAX )
1224 $ LDA = LDA + 1
1225* Skip tests if not enough room.
1226.GT. IF( LDANMAX )
1227 $ GO TO 100
1228 IF( PACKED )THEN
1229 LAA = ( N*( N + 1 ) )/2
1230 ELSE
1231 LAA = LDA*N
1232 END IF
1233.LE. NULL = N0
1234*
1235 DO 90 ICU = 1, 2
1236 UPLO = ICHU( ICU: ICU )
1237*
1238 DO 80 ICT = 1, 3
1239 TRANS = ICHT( ICT: ICT )
1240*
1241 DO 70 ICD = 1, 2
1242 DIAG = ICHD( ICD: ICD )
1243*
1244* Generate the matrix A.
1245*
1246 TRANSL = ZERO
1247 CALL CMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A,
1248 $ NMAX, AA, LDA, K, K, RESET, TRANSL )
1249*
1250 DO 60 IX = 1, NINC
1251 INCX = INC( IX )
1252 LX = ABS( INCX )*N
1253*
1254* Generate the vector X.
1255*
1256 TRANSL = HALF
1257 CALL CMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX,
1258 $ ABS( INCX ), 0, N - 1, RESET,
1259 $ TRANSL )
1260.GT. IF( N1 )THEN
1261 X( N/2 ) = ZERO
1262 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
1263 END IF
1264*
1265 NC = NC + 1
1266*
1267* Save every datum before calling the subroutine.
1268*
1269 UPLOS = UPLO
1270 TRANSS = TRANS
1271 DIAGS = DIAG
1272 NS = N
1273 KS = K
1274 DO 20 I = 1, LAA
1275 AS( I ) = AA( I )
1276 20 CONTINUE
1277 LDAS = LDA
1278 DO 30 I = 1, LX
1279 XS( I ) = XX( I )
1280 30 CONTINUE
1281 INCXS = INCX
1282*
1283* Call the subroutine.
1284*
1285.EQ. IF( SNAME( 4: 5 )'mv' )THEN
1286 IF( FULL )THEN
1287 IF( TRACE )
1288 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
1289 $ UPLO, TRANS, DIAG, N, LDA, INCX
1290 IF( REWI )
1291 $ REWIND NTRA
1292 CALL CTRMV( UPLO, TRANS, DIAG, N, AA, LDA,
1293 $ XX, INCX )
1294 ELSE IF( BANDED )THEN
1295 IF( TRACE )
1296 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1297 $ UPLO, TRANS, DIAG, N, K, LDA, INCX
1298 IF( REWI )
1299 $ REWIND NTRA
1300 CALL CTBMV( UPLO, TRANS, DIAG, N, K, AA,
1301 $ LDA, XX, INCX )
1302 ELSE IF( PACKED )THEN
1303 IF( TRACE )
1304 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1305 $ UPLO, TRANS, DIAG, N, INCX
1306 IF( REWI )
1307 $ REWIND NTRA
1308 CALL CTPMV( UPLO, TRANS, DIAG, N, AA, XX,
1309 $ INCX )
1310 END IF
1311.EQ. ELSE IF( SNAME( 4: 5 )'sv' )THEN
1312 IF( FULL )THEN
1313 IF( TRACE )
1314 $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
1315 $ UPLO, TRANS, DIAG, N, LDA, INCX
1316 IF( REWI )
1317 $ REWIND NTRA
1318 CALL CTRSV( UPLO, TRANS, DIAG, N, AA, LDA,
1319 $ XX, INCX )
1320 ELSE IF( BANDED )THEN
1321 IF( TRACE )
1322 $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
1323 $ UPLO, TRANS, DIAG, N, K, LDA, INCX
1324 IF( REWI )
1325 $ REWIND NTRA
1326 CALL CTBSV( UPLO, TRANS, DIAG, N, K, AA,
1327 $ LDA, XX, INCX )
1328 ELSE IF( PACKED )THEN
1329 IF( TRACE )
1330 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1331 $ UPLO, TRANS, DIAG, N, INCX
1332 IF( REWI )
1333 $ REWIND NTRA
1334 CALL CTPSV( UPLO, TRANS, DIAG, N, AA, XX,
1335 $ INCX )
1336 END IF
1337 END IF
1338*
1339* Check if error-exit was taken incorrectly.
1340*
1341.NOT. IF( OK )THEN
1342 WRITE( NOUT, FMT = 9992 )
1343 FATAL = .TRUE.
1344 GO TO 120
1345 END IF
1346*
1347* See what data changed inside subroutines.
1348*
1349.EQ. ISAME( 1 ) = UPLOUPLOS
1350.EQ. ISAME( 2 ) = TRANSTRANSS
1351.EQ. ISAME( 3 ) = DIAGDIAGS
1352.EQ. ISAME( 4 ) = NSN
1353 IF( FULL )THEN
1354 ISAME( 5 ) = LCE( AS, AA, LAA )
1355.EQ. ISAME( 6 ) = LDASLDA
1356 IF( NULL )THEN
1357 ISAME( 7 ) = LCE( XS, XX, LX )
1358 ELSE
1359 ISAME( 7 ) = LCERES( 'ge', ' ', 1, N, XS,
1360 $ XX, ABS( INCX ) )
1361 END IF
1362.EQ. ISAME( 8 ) = INCXSINCX
1363 ELSE IF( BANDED )THEN
1364.EQ. ISAME( 5 ) = KSK
1365 ISAME( 6 ) = LCE( AS, AA, LAA )
1366.EQ. ISAME( 7 ) = LDASLDA
1367 IF( NULL )THEN
1368 ISAME( 8 ) = LCE( XS, XX, LX )
1369 ELSE
1370 ISAME( 8 ) = LCERES( 'ge', ' ', 1, n, xs,
1371 $ xx, abs( incx ) )
1372 END IF
1373 isame( 9 ) = incxs.EQ.incx
1374 ELSE IF( packed )THEN
1375 isame( 5 ) = lce( as, aa, laa )
1376 IF( null )THEN
1377 isame( 6 ) = lce( xs, xx, lx )
1378 ELSE
1379 isame( 6 ) = lceres( 'GE', ' ', 1, n, xs,
1380 $ xx, abs( incx ) )
1381 END IF
1382 isame( 7 ) = incxs.EQ.incx
1383 END IF
1384*
1385* If data was incorrectly changed, report and
1386* return.
1387*
1388 same = .true.
1389 DO 40 i = 1, nargs
1390 same = same.AND.isame( i )
1391 IF( .NOT.isame( i ) )
1392 $ WRITE( nout, fmt = 9998 )i
1393 40 CONTINUE
1394 IF( .NOT.same )THEN
1395 fatal = .true.
1396 GO TO 120
1397 END IF
1398*
1399 IF( .NOT.null )THEN
1400 IF( sname( 4: 5 ).EQ.'MV' )THEN
1401*
1402* Check the result.
1403*
1404 CALL cmvch( trans, n, n, one, a, nmax, x,
1405 $ incx, zero, z, incx, xt, g,
1406 $ xx, eps, err, fatal, nout,
1407 $ .true. )
1408 ELSE IF( sname( 4: 5 ).EQ.'SV' )THEN
1409*
1410* Compute approximation to original vector.
1411*
1412 DO 50 i = 1, n
1413 z( i ) = xx( 1 + ( i - 1 )*
1414 $ abs( incx ) )
1415 xx( 1 + ( i - 1 )*abs( incx ) )
1416 $ = x( i )
1417 50 CONTINUE
1418 CALL cmvch( trans, n, n, one, a, nmax, z,
1419 $ incx, zero, x, incx, xt, g,
1420 $ xx, eps, err, fatal, nout,
1421 $ .false. )
1422 END IF
1423 errmax = max( errmax, err )
1424* If got really bad answer, report and return.
1425 IF( fatal )
1426 $ GO TO 120
1427 ELSE
1428* Avoid repeating tests with N.le.0.
1429 GO TO 110
1430 END IF
1431*
1432 60 CONTINUE
1433*
1434 70 CONTINUE
1435*
1436 80 CONTINUE
1437*
1438 90 CONTINUE
1439*
1440 100 CONTINUE
1441*
1442 110 CONTINUE
1443*
1444* Report result.
1445*
1446 IF( errmax.LT.thresh )THEN
1447 WRITE( nout, fmt = 9999 )sname, nc
1448 ELSE
1449 WRITE( nout, fmt = 9997 )sname, nc, errmax
1450 END IF
1451 GO TO 130
1452*
1453 120 CONTINUE
1454 WRITE( nout, fmt = 9996 )sname
1455 IF( full )THEN
1456 WRITE( nout, fmt = 9993 )nc, sname, uplo, trans, diag, n, lda,
1457 $ incx
1458 ELSE IF( banded )THEN
1459 WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, diag, n, k,
1460 $ lda, incx
1461 ELSE IF( packed )THEN
1462 WRITE( nout, fmt = 9995 )nc, sname, uplo, trans, diag, n, incx
1463 END IF
1464*
1465 130 CONTINUE
1466 RETURN
1467*
1468 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1469 $ 'S)' )
1470 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1471 $ 'ANGED INCORRECTLY *******' )
1472 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1473 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1474 $ ' - SUSPECT *******' )
1475 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1476 9995 FORMAT( 1x, i6, ': ', a6, '(', 3( '''', a1, ''',' ), i3, ', AP, ',
1477 $ 'X,', i2, ') .' )
1478 9994 FORMAT( 1x, i6, ': ', a6, '(', 3( '''', a1, ''',' ), 2( i3, ',' ),
1479 $ ' A,', i3, ', X,', i2, ') .' )
1480 9993 FORMAT( 1x, i6, ': ', a6, '(', 3( '''', a1, ''',' ), i3, ', A,',
1481 $ i3, ', X,', i2, ') .' )
1482 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1483 $ '******' )
1484*
1485* End of CCHK3
1486*
1487 END
1488 SUBROUTINE cchk4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1489 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1490 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1491 $ Z )
1492*
1493* Tests CGERC and CGERU.
1494*
1495* Auxiliary routine for test program for Level 2 Blas.
1496*
1497* -- Written on 10-August-1987.
1498* Richard Hanson, Sandia National Labs.
1499* Jeremy Du Croz, NAG Central Office.
1500*
1501* .. Parameters ..
1502 COMPLEX ZERO, HALF, ONE
1503 PARAMETER ( ZERO = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
1504 $ one = ( 1.0, 0.0 ) )
1505 REAL RZERO
1506 PARAMETER ( RZERO = 0.0 )
1507* .. Scalar Arguments ..
1508 real eps, thresh
1509 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1510 LOGICAL FATAL, REWI, TRACE
1511 CHARACTER*6 SNAME
1512* .. Array Arguments ..
1513 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1514 $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
1515 $ xx( nmax*incmax ), y( nmax ),
1516 $ ys( nmax*incmax ), yt( nmax ),
1517 $ yy( nmax*incmax ), z( nmax )
1518 REAL G( NMAX )
1519 INTEGER IDIM( NIDIM ), INC( NINC )
1520* .. Local Scalars ..
1521 COMPLEX ALPHA, ALS, TRANSL
1522 REAL ERR, ERRMAX
1523 INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
1524 $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
1525 $ NC, ND, NS
1526 LOGICAL CONJ, NULL, RESET, SAME
1527* .. Local Arrays ..
1528 COMPLEX W( 1 )
1529 LOGICAL ISAME( 13 )
1530* .. External Functions ..
1531 LOGICAL LCE, LCERES
1532 EXTERNAL lce, lceres
1533* .. External Subroutines ..
1534 EXTERNAL cgerc, cgeru, cmake, cmvch
1535* .. Intrinsic Functions ..
1536 INTRINSIC abs, conjg, max, min
1537* .. Scalars in Common ..
1538 INTEGER INFOT, NOUTC
1539 LOGICAL LERR, OK
1540* .. Common blocks ..
1541 COMMON /infoc/infot, noutc, ok, lerr
1542* .. Executable Statements ..
1543 conj = sname( 5: 5 ).EQ.'C'
1544* Define the number of arguments.
1545 nargs = 9
1546*
1547 nc = 0
1548 reset = .true.
1549 errmax = rzero
1550*
1551 DO 120 in = 1, nidim
1552 n = idim( in )
1553 nd = n/2 + 1
1554*
1555 DO 110 im = 1, 2
1556 IF( im.EQ.1 )
1557 $ m = max( n - nd, 0 )
1558 IF( im.EQ.2 )
1559 $ m = min( n + nd, nmax )
1560*
1561* Set LDA to 1 more than minimum value if room.
1562 lda = m
1563 IF( lda.LT.nmax )
1564 $ lda = lda + 1
1565* Skip tests if not enough room.
1566 IF( lda.GT.nmax )
1567 $ GO TO 110
1568 laa = lda*n
1569 null = n.LE.0.OR.m.LE.0
1570*
1571 DO 100 ix = 1, ninc
1572 incx = inc( ix )
1573 lx = abs( incx )*m
1574*
1575* Generate the vector X.
1576*
1577 transl = half
1578 CALL cmake( 'GE', ' ', ' ', 1, m, x, 1, xx, abs( incx ),
1579 $ 0, m - 1, reset, transl )
1580 IF( m.GT.1 )THEN
1581 x( m/2 ) = zero
1582 xx( 1 + abs( incx )*( m/2 - 1 ) ) = zero
1583 END IF
1584*
1585 DO 90 iy = 1, ninc
1586 incy = inc( iy )
1587 ly = abs( incy )*n
1588*
1589* Generate the vector Y.
1590*
1591 transl = zero
1592 CALL cmake( 'GE', ' ', ' ', 1, n, y, 1, yy,
1593 $ abs( incy ), 0, n - 1, reset, transl )
1594 IF( n.GT.1 )THEN
1595 y( n/2 ) = zero
1596 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
1597 END IF
1598*
1599 DO 80 ia = 1, nalf
1600 alpha = alf( ia )
1601*
1602* Generate the matrix A.
1603*
1604 transl = zero
1605 CALL cmake( sname( 2: 3 ), ' ', ' ', m, n, a, nmax,
1606 $ aa, lda, m - 1, n - 1, reset, transl )
1607*
1608 nc = nc + 1
1609*
1610* Save every datum before calling the subroutine.
1611*
1612 ms = m
1613 ns = n
1614 als = alpha
1615 DO 10 i = 1, laa
1616 as( i ) = aa( i )
1617 10 CONTINUE
1618 ldas = lda
1619 DO 20 i = 1, lx
1620 xs( i ) = xx( i )
1621 20 CONTINUE
1622 incxs = incx
1623 DO 30 i = 1, ly
1624 ys( i ) = yy( i )
1625 30 CONTINUE
1626 incys = incy
1627*
1628* Call the subroutine.
1629*
1630 IF( trace )
1631 $ WRITE( ntra, fmt = 9994 )nc, sname, m, n,
1632 $ alpha, incx, incy, lda
1633 IF( conj )THEN
1634 IF( rewi )
1635 $ rewind ntra
1636 CALL cgerc( m, n, alpha, xx, incx, yy, incy, aa,
1637 $ lda )
1638 ELSE
1639 IF( rewi )
1640 $ rewind ntra
1641 CALL cgeru( m, n, alpha, xx, incx, yy, incy, aa,
1642 $ lda )
1643 END IF
1644*
1645* Check if error-exit was taken incorrectly.
1646*
1647 IF( .NOT.ok )THEN
1648 WRITE( nout, fmt = 9993 )
1649 fatal = .true.
1650 GO TO 140
1651 END IF
1652*
1653* See what data changed inside subroutine.
1654*
1655 isame( 1 ) = ms.EQ.m
1656 isame( 2 ) = ns.EQ.n
1657 isame( 3 ) = als.EQ.alpha
1658 isame( 4 ) = lce( xs, xx, lx )
1659 isame( 5 ) = incxs.EQ.incx
1660 isame( 6 ) = lce( ys, yy, ly )
1661 isame( 7 ) = incys.EQ.incy
1662 IF( null )THEN
1663 isame( 8 ) = lce( as, aa, laa )
1664 ELSE
1665 isame( 8 ) = lceres( 'GE', ' ', m, n, as, aa,
1666 $ lda )
1667 END IF
1668 isame( 9 ) = ldas.EQ.lda
1669*
1670* If data was incorrectly changed, report and return.
1671*
1672 same = .true.
1673 DO 40 i = 1, nargs
1674 same = same.AND.isame( i )
1675 IF( .NOT.isame( i ) )
1676 $ WRITE( nout, fmt = 9998 )i
1677 40 CONTINUE
1678 IF( .NOT.same )THEN
1679 fatal = .true.
1680 GO TO 140
1681 END IF
1682*
1683 IF( .NOT.null )THEN
1684*
1685* Check the result column by column.
1686*
1687 IF( incx.GT.0 )THEN
1688 DO 50 i = 1, m
1689 z( i ) = x( i )
1690 50 CONTINUE
1691 ELSE
1692 DO 60 i = 1, m
1693 z( i ) = x( m - i + 1 )
1694 60 CONTINUE
1695 END IF
1696 DO 70 j = 1, n
1697 IF( incy.GT.0 )THEN
1698 w( 1 ) = y( j )
1699 ELSE
1700 w( 1 ) = y( n - j + 1 )
1701 END IF
1702 IF( conj )
1703 $ w( 1 ) = conjg( w( 1 ) )
1704 CALL cmvch( 'N', m, 1, alpha, z, nmax, w, 1,
1705 $ one, a( 1, j ), 1, yt, g,
1706 $ aa( 1 + ( j - 1 )*lda ), eps,
1707 $ err, fatal, nout, .true. )
1708 errmax = max( errmax, err )
1709* If got really bad answer, report and return.
1710 IF( fatal )
1711 $ GO TO 130
1712 70 CONTINUE
1713 ELSE
1714* Avoid repeating tests with M.le.0 or N.le.0.
1715 GO TO 110
1716 END IF
1717*
1718 80 CONTINUE
1719*
1720 90 CONTINUE
1721*
1722 100 CONTINUE
1723*
1724 110 CONTINUE
1725*
1726 120 CONTINUE
1727*
1728* Report result.
1729*
1730 IF( errmax.LT.thresh )THEN
1731 WRITE( nout, fmt = 9999 )sname, nc
1732 ELSE
1733 WRITE( nout, fmt = 9997 )sname, nc, errmax
1734 END IF
1735 GO TO 150
1736*
1737 130 CONTINUE
1738 WRITE( nout, fmt = 9995 )j
1739*
1740 140 CONTINUE
1741 WRITE( nout, fmt = 9996 )sname
1742 WRITE( nout, fmt = 9994 )nc, sname, m, n, alpha, incx, incy, lda
1743*
1744 150 CONTINUE
1745 RETURN
1746*
1747 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1748 $ 'S)' )
1749 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1750 $ 'ANGED INCORRECTLY *******' )
1751 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1752 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1753 $ ' - SUSPECT *******' )
1754 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1755 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1756 9994 FORMAT( 1x, i6, ': ', a6, '(', 2( i3, ',' ), '(', f4.1, ',', f4.1,
1757 $ '), X,', i2, ', Y,', i2, ', A,', i3, ') ',
1758 $ ' .' )
1759 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1760 $ '******' )
1761*
1762* End of CCHK4
1763*
1764 END
1765 SUBROUTINE cchk5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1766 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1767 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1768 $ Z )
1769*
1770* Tests CHER and CHPR.
1771*
1772* Auxiliary routine for test program for Level 2 Blas.
1773*
1774* -- Written on 10-August-1987.
1775* Richard Hanson, Sandia National Labs.
1776* Jeremy Du Croz, NAG Central Office.
1777*
1778* .. Parameters ..
1779 COMPLEX ZERO, HALF, ONE
1780 PARAMETER ( ZERO = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
1781 $ one = ( 1.0, 0.0 ) )
1782 REAL RZERO
1783 PARAMETER ( RZERO = 0.0 )
1784* .. Scalar Arguments ..
1785 real eps, thresh
1786 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1787 LOGICAL FATAL, REWI, TRACE
1788 CHARACTER*6 SNAME
1789* .. Array Arguments ..
1790 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1791 $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
1792 $ xx( nmax*incmax ), y( nmax ),
1793 $ ys( nmax*incmax ), yt( nmax ),
1794 $ yy( nmax*incmax ), z( nmax )
1795 REAL G( NMAX )
1796 INTEGER IDIM( NIDIM ), INC( NINC )
1797* .. Local Scalars ..
1798 COMPLEX ALPHA, TRANSL
1799 REAL ERR, ERRMAX, RALPHA, RALS
1800 INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1801 $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
1802 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
1803 CHARACTER*1 UPLO, UPLOS
1804 CHARACTER*2 ICH
1805* .. Local Arrays ..
1806 COMPLEX W( 1 )
1807 LOGICAL ISAME( 13 )
1808* .. External Functions ..
1809 LOGICAL LCE, LCERES
1810 EXTERNAL lce, lceres
1811* .. External Subroutines ..
1812 EXTERNAL cher, chpr, cmake, cmvch
1813* .. Intrinsic Functions ..
1814 INTRINSIC abs, cmplx, conjg, max, real
1815* .. Scalars in Common ..
1816 INTEGER INFOT, NOUTC
1817 LOGICAL LERR, OK
1818* .. Common blocks ..
1819 COMMON /infoc/infot, noutc, ok, lerr
1820* .. Data statements ..
1821 DATA ich/'UL'/
1822* .. Executable Statements ..
1823 full = sname( 3: 3 ).EQ.'E'
1824 packed = sname( 3: 3 ).EQ.'P'
1825* Define the number of arguments.
1826 IF( full )THEN
1827 nargs = 7
1828 ELSE IF( packed )THEN
1829 nargs = 6
1830 END IF
1831*
1832 nc = 0
1833 reset = .true.
1834 errmax = rzero
1835*
1836 DO 100 in = 1, nidim
1837 n = idim( in )
1838* Set LDA to 1 more than minimum value if room.
1839 lda = n
1840 IF( lda.LT.nmax )
1841 $ lda = lda + 1
1842* Skip tests if not enough room.
1843 IF( lda.GT.nmax )
1844 $ GO TO 100
1845 IF( packed )THEN
1846 laa = ( n*( n + 1 ) )/2
1847 ELSE
1848 laa = lda*n
1849 END IF
1850*
1851 DO 90 ic = 1, 2
1852 uplo = ich( ic: ic )
1853 upper = uplo.EQ.'U'
1854*
1855 DO 80 ix = 1, ninc
1856 incx = inc( ix )
1857 lx = abs( incx )*n
1858*
1859* Generate the vector X.
1860*
1861 transl = half
1862 CALL cmake( 'GE', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
1863 $ 0, n - 1, reset, transl )
1864 IF( n.GT.1 )THEN
1865 x( n/2 ) = zero
1866 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1867 END IF
1868*
1869 DO 70 ia = 1, nalf
1870 ralpha = real( alf( ia ) )
1871 alpha = cmplx( ralpha, rzero )
1872 null = n.LE.0.OR.ralpha.EQ.rzero
1873*
1874* Generate the matrix A.
1875*
1876 transl = zero
1877 CALL cmake( sname( 2: 3 ), uplo, ' ', n, n, a, nmax,
1878 $ aa, lda, n - 1, n - 1, reset, transl )
1879*
1880 nc = nc + 1
1881*
1882* Save every datum before calling the subroutine.
1883*
1884 uplos = uplo
1885 ns = n
1886 rals = ralpha
1887 DO 10 i = 1, laa
1888 as( i ) = aa( i )
1889 10 CONTINUE
1890 ldas = lda
1891 DO 20 i = 1, lx
1892 xs( i ) = xx( i )
1893 20 CONTINUE
1894 incxs = incx
1895*
1896* Call the subroutine.
1897*
1898 IF( full )THEN
1899 IF( trace )
1900 $ WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
1901 $ ralpha, incx, lda
1902 IF( rewi )
1903 $ rewind ntra
1904 CALL cher( uplo, n, ralpha, xx, incx, aa, lda )
1905 ELSE IF( packed )THEN
1906 IF( trace )
1907 $ WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
1908 $ ralpha, incx
1909 IF( rewi )
1910 $ rewind ntra
1911 CALL chpr( uplo, n, ralpha, xx, incx, aa )
1912 END IF
1913*
1914* Check if error-exit was taken incorrectly.
1915*
1916 IF( .NOT.ok )THEN
1917 WRITE( nout, fmt = 9992 )
1918 fatal = .true.
1919 GO TO 120
1920 END IF
1921*
1922* See what data changed inside subroutines.
1923*
1924 isame( 1 ) = uplo.EQ.uplos
1925 isame( 2 ) = ns.EQ.n
1926 isame( 3 ) = rals.EQ.ralpha
1927 isame( 4 ) = lce( xs, xx, lx )
1928 isame( 5 ) = incxs.EQ.incx
1929 IF( null )THEN
1930 isame( 6 ) = lce( as, aa, laa )
1931 ELSE
1932 isame( 6 ) = lceres( sname( 2: 3 ), uplo, n, n, as,
1933 $ aa, lda )
1934 END IF
1935 IF( .NOT.packed )THEN
1936 isame( 7 ) = ldas.EQ.lda
1937 END IF
1938*
1939* If data was incorrectly changed, report and return.
1940*
1941 same = .true.
1942 DO 30 i = 1, nargs
1943 same = same.AND.isame( i )
1944 IF( .NOT.isame( i ) )
1945 $ WRITE( nout, fmt = 9998 )i
1946 30 CONTINUE
1947 IF( .NOT.same )THEN
1948 fatal = .true.
1949 GO TO 120
1950 END IF
1951*
1952 IF( .NOT.null )THEN
1953*
1954* Check the result column by column.
1955*
1956 IF( incx.GT.0 )THEN
1957 DO 40 i = 1, n
1958 z( i ) = x( i )
1959 40 CONTINUE
1960 ELSE
1961 DO 50 i = 1, n
1962 z( i ) = x( n - i + 1 )
1963 50 CONTINUE
1964 END IF
1965 ja = 1
1966 DO 60 j = 1, n
1967 w( 1 ) = conjg( z( j ) )
1968 IF( upper )THEN
1969 jj = 1
1970 lj = j
1971 ELSE
1972 jj = j
1973 lj = n - j + 1
1974 END IF
1975 CALL cmvch( 'N', lj, 1, alpha, z( jj ), lj, w,
1976 $ 1, one, a( jj, j ), 1, yt, g,
1977 $ aa( ja ), eps, err, fatal, nout,
1978 $ .true. )
1979 IF( full )THEN
1980 IF( upper )THEN
1981 ja = ja + lda
1982 ELSE
1983 ja = ja + lda + 1
1984 END IF
1985 ELSE
1986 ja = ja + lj
1987 END IF
1988 errmax = max( errmax, err )
1989* If got really bad answer, report and return.
1990 IF( fatal )
1991 $ GO TO 110
1992 60 CONTINUE
1993 ELSE
1994* Avoid repeating tests if N.le.0.
1995 IF( n.LE.0 )
1996 $ GO TO 100
1997 END IF
1998*
1999 70 CONTINUE
2000*
2001 80 CONTINUE
2002*
2003 90 CONTINUE
2004*
2005 100 CONTINUE
2006*
2007* Report result.
2008*
2009 IF( errmax.LT.thresh )THEN
2010 WRITE( nout, fmt = 9999 )sname, nc
2011 ELSE
2012 WRITE( nout, fmt = 9997 )sname, nc, errmax
2013 END IF
2014 GO TO 130
2015*
2016 110 CONTINUE
2017 WRITE( nout, fmt = 9995 )j
2018*
2019 120 CONTINUE
2020 WRITE( nout, fmt = 9996 )sname
2021 IF( full )THEN
2022 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, ralpha, incx, lda
2023 ELSE IF( packed )THEN
2024 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, ralpha, incx
2025 END IF
2026*
2027 130 CONTINUE
2028 RETURN
2029*
2030 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
2031 $ 'S)' )
2032 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2033 $ 'ANGED INCORRECTLY *******' )
2034 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2035 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2036 $ ' - SUSPECT *******' )
2037 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
2038 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2039 9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
2040 $ i2, ', AP) .' )
2041 9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', x,',
2042 $ I2, ', a,', I3, ') .' )
2043 9992 FORMAT( ' ******* fatal error - error-EXIT taken on valid CALL *',
2044 $ '******' )
2045*
2046* End of CCHK5
2047*
2048 END
2049 SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
2050 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
2051 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
2052 $ Z )
2053*
2054* Tests CHER2 and CHPR2.
2055*
2056* Auxiliary routine for test program for Level 2 Blas.
2057*
2058* -- Written on 10-August-1987.
2059* Richard Hanson, Sandia National Labs.
2060* Jeremy Du Croz, NAG Central Office.
2061*
2062* .. Parameters ..
2063 COMPLEX ZERO, HALF, ONE
2064 PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ),
2065 $ ONE = ( 1.0, 0.0 ) )
2066 REAL RZERO
2067 PARAMETER ( RZERO = 0.0 )
2068* .. Scalar Arguments ..
2069 REAL EPS, THRESH
2070 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
2071 LOGICAL FATAL, REWI, TRACE
2072 CHARACTER*6 SNAME
2073* .. Array Arguments ..
2074 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2075 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
2076 $ XX( NMAX*INCMAX ), Y( NMAX ),
2077 $ YS( NMAX*INCMAX ), YT( NMAX ),
2078 $ YY( NMAX*INCMAX ), Z( NMAX, 2 )
2079 REAL G( NMAX )
2080 INTEGER IDIM( NIDIM ), INC( NINC )
2081* .. Local Scalars ..
2082 COMPLEX ALPHA, ALS, TRANSL
2083 REAL ERR, ERRMAX
2084 INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
2085 $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
2086 $ NARGS, NC, NS
2087 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
2088 CHARACTER*1 UPLO, UPLOS
2089 CHARACTER*2 ICH
2090* .. Local Arrays ..
2091 COMPLEX W( 2 )
2092 LOGICAL ISAME( 13 )
2093* .. External Functions ..
2094 LOGICAL LCE, LCERES
2095 EXTERNAL LCE, LCERES
2096* .. External Subroutines ..
2097 EXTERNAL CHER2, CHPR2, CMAKE, CMVCH
2098* .. Intrinsic Functions ..
2099 INTRINSIC ABS, CONJG, MAX
2100* .. Scalars in Common ..
2101 INTEGER INFOT, NOUTC
2102 LOGICAL LERR, OK
2103* .. Common blocks ..
2104 COMMON /INFOC/INFOT, NOUTC, OK, LERR
2105* .. Data statements ..
2106 DATA ICH/'ul'/
2107* .. Executable Statements ..
2108.EQ. FULL = SNAME( 3: 3 )'e'
2109.EQ. PACKED = SNAME( 3: 3 )'p'
2110* Define the number of arguments.
2111 IF( FULL )THEN
2112 NARGS = 9
2113 ELSE IF( PACKED )THEN
2114 NARGS = 8
2115 END IF
2116*
2117 NC = 0
2118 RESET = .TRUE.
2119 ERRMAX = RZERO
2120*
2121 DO 140 IN = 1, NIDIM
2122 N = IDIM( IN )
2123* Set LDA to 1 more than minimum value if room.
2124 LDA = N
2125.LT. IF( LDANMAX )
2126 $ LDA = LDA + 1
2127* Skip tests if not enough room.
2128.GT. IF( LDANMAX )
2129 $ GO TO 140
2130 IF( PACKED )THEN
2131 LAA = ( N*( N + 1 ) )/2
2132 ELSE
2133 LAA = LDA*N
2134 END IF
2135*
2136 DO 130 IC = 1, 2
2137 UPLO = ICH( IC: IC )
2138.EQ. UPPER = UPLO'u'
2139*
2140 DO 120 IX = 1, NINC
2141 INCX = INC( IX )
2142 LX = ABS( INCX )*N
2143*
2144* Generate the vector X.
2145*
2146 TRANSL = HALF
2147 CALL CMAKE( 'ge', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
2148 $ 0, N - 1, RESET, TRANSL )
2149.GT. IF( N1 )THEN
2150 X( N/2 ) = ZERO
2151 XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
2152 END IF
2153*
2154 DO 110 IY = 1, NINC
2155 INCY = INC( IY )
2156 LY = ABS( INCY )*N
2157*
2158* Generate the vector Y.
2159*
2160 TRANSL = ZERO
2161 CALL CMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY,
2162 $ ABS( INCY ), 0, N - 1, RESET, TRANSL )
2163.GT. IF( N1 )THEN
2164 Y( N/2 ) = ZERO
2165 YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
2166 END IF
2167*
2168 DO 100 IA = 1, NALF
2169 ALPHA = ALF( IA )
2170.LE..OR..EQ. NULL = N0ALPHAZERO
2171*
2172* Generate the matrix A.
2173*
2174 TRANSL = ZERO
2175 CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A,
2176 $ NMAX, AA, LDA, N - 1, N - 1, RESET,
2177 $ TRANSL )
2178*
2179 NC = NC + 1
2180*
2181* Save every datum before calling the subroutine.
2182*
2183 UPLOS = UPLO
2184 NS = N
2185 ALS = ALPHA
2186 DO 10 I = 1, LAA
2187 AS( I ) = AA( I )
2188 10 CONTINUE
2189 LDAS = LDA
2190 DO 20 I = 1, LX
2191 XS( I ) = XX( I )
2192 20 CONTINUE
2193 INCXS = INCX
2194 DO 30 I = 1, LY
2195 YS( I ) = YY( I )
2196 30 CONTINUE
2197 INCYS = INCY
2198*
2199* Call the subroutine.
2200*
2201 IF( FULL )THEN
2202 IF( TRACE )
2203 $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
2204 $ ALPHA, INCX, INCY, LDA
2205 IF( REWI )
2206 $ REWIND NTRA
2207 CALL CHER2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
2208 $ AA, LDA )
2209 ELSE IF( PACKED )THEN
2210 IF( TRACE )
2211 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
2212 $ ALPHA, INCX, INCY
2213 IF( REWI )
2214 $ REWIND NTRA
2215 CALL CHPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
2216 $ AA )
2217 END IF
2218*
2219* Check if error-exit was taken incorrectly.
2220*
2221.NOT. IF( OK )THEN
2222 WRITE( NOUT, FMT = 9992 )
2223 FATAL = .TRUE.
2224 GO TO 160
2225 END IF
2226*
2227* See what data changed inside subroutines.
2228*
2229.EQ. ISAME( 1 ) = UPLOUPLOS
2230.EQ. ISAME( 2 ) = NSN
2231.EQ. ISAME( 3 ) = ALSALPHA
2232 ISAME( 4 ) = LCE( XS, XX, LX )
2233.EQ. ISAME( 5 ) = INCXSINCX
2234 ISAME( 6 ) = LCE( YS, YY, LY )
2235.EQ. ISAME( 7 ) = INCYSINCY
2236 IF( NULL )THEN
2237 ISAME( 8 ) = LCE( AS, AA, LAA )
2238 ELSE
2239 ISAME( 8 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N,
2240 $ AS, AA, LDA )
2241 END IF
2242.NOT. IF( PACKED )THEN
2243.EQ. ISAME( 9 ) = LDASLDA
2244 END IF
2245*
2246* If data was incorrectly changed, report and return.
2247*
2248 SAME = .TRUE.
2249 DO 40 I = 1, NARGS
2250.AND. SAME = SAMEISAME( I )
2251.NOT. IF( ISAME( I ) )
2252 $ WRITE( NOUT, FMT = 9998 )I
2253 40 CONTINUE
2254.NOT. IF( SAME )THEN
2255 FATAL = .TRUE.
2256 GO TO 160
2257 END IF
2258*
2259.NOT. IF( NULL )THEN
2260*
2261* Check the result column by column.
2262*
2263.GT. IF( INCX0 )THEN
2264 DO 50 I = 1, N
2265 Z( I, 1 ) = X( I )
2266 50 CONTINUE
2267 ELSE
2268 DO 60 I = 1, N
2269 Z( I, 1 ) = X( N - I + 1 )
2270 60 CONTINUE
2271 END IF
2272.GT. IF( INCY0 )THEN
2273 DO 70 I = 1, N
2274 Z( I, 2 ) = Y( I )
2275 70 CONTINUE
2276 ELSE
2277 DO 80 I = 1, N
2278 Z( I, 2 ) = Y( N - I + 1 )
2279 80 CONTINUE
2280 END IF
2281 JA = 1
2282 DO 90 J = 1, N
2283 W( 1 ) = ALPHA*CONJG( Z( J, 2 ) )
2284 W( 2 ) = CONJG( ALPHA )*CONJG( Z( J, 1 ) )
2285 IF( UPPER )THEN
2286 JJ = 1
2287 LJ = J
2288 ELSE
2289 JJ = J
2290 LJ = N - J + 1
2291 END IF
2292 CALL CMVCH( 'n', LJ, 2, ONE, Z( JJ, 1 ),
2293 $ NMAX, W, 1, ONE, A( JJ, J ), 1,
2294 $ YT, G, AA( JA ), EPS, ERR, FATAL,
2295 $ NOUT, .TRUE. )
2296 IF( FULL )THEN
2297 IF( UPPER )THEN
2298 JA = JA + LDA
2299 ELSE
2300 JA = JA + LDA + 1
2301 END IF
2302 ELSE
2303 JA = JA + LJ
2304 END IF
2305 ERRMAX = MAX( ERRMAX, ERR )
2306* If got really bad answer, report and return.
2307 IF( FATAL )
2308 $ GO TO 150
2309 90 CONTINUE
2310 ELSE
2311* Avoid repeating tests with N.le.0.
2312.LE. IF( N0 )
2313 $ GO TO 140
2314 END IF
2315*
2316 100 CONTINUE
2317*
2318 110 CONTINUE
2319*
2320 120 CONTINUE
2321*
2322 130 CONTINUE
2323*
2324 140 CONTINUE
2325*
2326* Report result.
2327*
2328.LT. IF( ERRMAXTHRESH )THEN
2329 WRITE( NOUT, FMT = 9999 )SNAME, NC
2330 ELSE
2331 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
2332 END IF
2333 GO TO 170
2334*
2335 150 CONTINUE
2336 WRITE( NOUT, FMT = 9995 )J
2337*
2338 160 CONTINUE
2339 WRITE( NOUT, FMT = 9996 )SNAME
2340 IF( FULL )THEN
2341 WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX,
2342 $ INCY, LDA
2343 ELSE IF( PACKED )THEN
2344 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY
2345 END IF
2346*
2347 170 CONTINUE
2348 RETURN
2349*
2350 9999 FORMAT( ' ', A6, ' passed the computational tests(', I6, ' call',
2351 $ 's)' )
2352 9998 FORMAT( ' ******* fatal error - PARAMETER number ', I2, ' was ch',
2353 $ 'anged incorrectly *******' )
2354 9997 FORMAT( ' ', A6, ' completed the computational tests(', I6, ' c',
2355 $ 'alls)', /' ******* but with maximum test ratio', F8.2,
2356 $ ' - suspect *******' )
2357 9996 FORMAT( ' ******* ', A6, ' failed on CALL number:' )
2358 9995 FORMAT( ' these are the results for column ', I3 )
2359 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',',
2360 $ F4.1, '), x,', I2, ', y,', I2, ', ap) ',
2361 $ ' .' )
2362 9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',(', f4.1, ',',
2363 $ f4.1, '), X,', i2, ', Y,', i2, ', A,', i3, ') ',
2364 $ ' .' )
2365 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2366 $ '******' )
2367*
2368* End of CCHK6
2369*
2370 END
2371 SUBROUTINE cchke( ISNUM, SRNAMT, NOUT )
2372*
2373* Tests the error exits from the Level 2 Blas.
2374* Requires a special version of the error-handling routine XERBLA.
2375* ALPHA, RALPHA, BETA, A, X and Y should not need to be defined.
2376*
2377* Auxiliary routine for test program for Level 2 Blas.
2378*
2379* -- Written on 10-August-1987.
2380* Richard Hanson, Sandia National Labs.
2381* Jeremy Du Croz, NAG Central Office.
2382*
2383* .. Scalar Arguments ..
2384 INTEGER ISNUM, NOUT
2385 CHARACTER*6 SRNAMT
2386* .. Scalars in Common ..
2387 INTEGER INFOT, NOUTC
2388 LOGICAL LERR, OK
2389* .. Local Scalars ..
2390 COMPLEX ALPHA, BETA
2391 REAL RALPHA
2392* .. Local Arrays ..
2393 COMPLEX A( 1, 1 ), X( 1 ), Y( 1 )
2394* .. External Subroutines ..
2395 EXTERNAL CGBMV, CGEMV, CGERC, CGERU, CHBMV, CHEMV, CHER,
2396 $ cher2, chkxer, chpmv, chpr, chpr2, ctbmv,
2397 $ ctbsv, ctpmv, ctpsv, ctrmv, ctrsv
2398* .. Common blocks ..
2399 COMMON /infoc/infot, noutc, ok, lerr
2400* .. Executable Statements ..
2401* OK is set to .FALSE. by the special version of XERBLA or by CHKXER
2402* if anything is wrong.
2403 ok = .true.
2404* LERR is set to .TRUE. by the special version of XERBLA each time
2405* it is called, and is then tested and re-set by CHKXER.
2406 lerr = .false.
2407 GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
2408 $ 90, 100, 110, 120, 130, 140, 150, 160,
2409 $ 170 )isnum
2410 10 infot = 1
2411 CALL cgemv( '/', 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2412 CALL chkxer( srnamt, infot, nout, lerr, ok )
2413 infot = 2
2414 CALL cgemv( 'N', -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2415 CALL chkxer( srnamt, infot, nout, lerr, ok )
2416 infot = 3
2417 CALL cgemv( 'N', 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2418 CALL chkxer( srnamt, infot, nout, lerr, ok )
2419 infot = 6
2420 CALL cgemv( 'N', 2, 0, alpha, a, 1, x, 1, beta, y, 1 )
2421 CALL chkxer( srnamt, infot, nout, lerr, ok )
2422 infot = 8
2423 CALL cgemv( 'N', 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2424 CALL chkxer( srnamt, infot, nout, lerr, ok )
2425 infot = 11
2426 CALL cgemv( 'N', 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2427 CALL chkxer( srnamt, infot, nout, lerr, ok )
2428 GO TO 180
2429 20 infot = 1
2430 CALL cgbmv( '/', 0, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2431 CALL chkxer( srnamt, infot, nout, lerr, ok )
2432 infot = 2
2433 CALL cgbmv( 'N', -1, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2434 CALL chkxer( srnamt, infot, nout, lerr, ok )
2435 infot = 3
2436 CALL cgbmv( 'N', 0, -1, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2437 CALL chkxer( srnamt, infot, nout, lerr, ok )
2438 infot = 4
2439 CALL cgbmv( 'N', 0, 0, -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2440 CALL chkxer( srnamt, infot, nout, lerr, ok )
2441 infot = 5
2442 CALL cgbmv( 'N', 2, 0, 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2443 CALL chkxer( srnamt, infot, nout, lerr, ok )
2444 infot = 8
2445 CALL cgbmv( 'N', 0, 0, 1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2446 CALL chkxer( srnamt, infot, nout, lerr, ok )
2447 infot = 10
2448 CALL cgbmv( 'N', 0, 0, 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2449 CALL chkxer( srnamt, infot, nout, lerr, ok )
2450 infot = 13
2451 CALL cgbmv( 'N', 0, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2452 CALL chkxer( srnamt, infot, nout, lerr, ok )
2453 GO TO 180
2454 30 infot = 1
2455 CALL chemv( '/', 0, alpha, a, 1, x, 1, beta, y, 1 )
2456 CALL chkxer( srnamt, infot, nout, lerr, ok )
2457 infot = 2
2458 CALL chemv( 'U', -1, alpha, a, 1, x, 1, beta, y, 1 )
2459 CALL chkxer( srnamt, infot, nout, lerr, ok )
2460 infot = 5
2461 CALL chemv( 'U', 2, alpha, a, 1, x, 1, beta, y, 1 )
2462 CALL chkxer( srnamt, infot, nout, lerr, ok )
2463 infot = 7
2464 CALL chemv( 'U', 0, alpha, a, 1, x, 0, beta, y, 1 )
2465 CALL chkxer( srnamt, infot, nout, lerr, ok )
2466 infot = 10
2467 CALL chemv( 'U', 0, alpha, a, 1, x, 1, beta, y, 0 )
2468 CALL chkxer( srnamt, infot, nout, lerr, ok )
2469 GO TO 180
2470 40 infot = 1
2471 CALL chbmv( '/', 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2472 CALL chkxer( srnamt, infot, nout, lerr, ok )
2473 infot = 2
2474 CALL chbmv( 'U', -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2475 CALL chkxer( srnamt, infot, nout, lerr, ok )
2476 infot = 3
2477 CALL chbmv( 'U', 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2478 CALL chkxer( srnamt, infot, nout, lerr, ok )
2479 infot = 6
2480 CALL chbmv( 'U', 0, 1, alpha, a, 1, x, 1, beta, y, 1 )
2481 CALL chkxer( srnamt, infot, nout, lerr, ok )
2482 infot = 8
2483 CALL chbmv( 'U', 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2484 CALL chkxer( srnamt, infot, nout, lerr, ok )
2485 infot = 11
2486 CALL chbmv( 'U', 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2487 CALL chkxer( srnamt, infot, nout, lerr, ok )
2488 GO TO 180
2489 50 infot = 1
2490 CALL chpmv( '/', 0, alpha, a, x, 1, beta, y, 1 )
2491 CALL chkxer( srnamt, infot, nout, lerr, ok )
2492 infot = 2
2493 CALL chpmv( 'U', -1, alpha, a, x, 1, beta, y, 1 )
2494 CALL chkxer( srnamt, infot, nout, lerr, ok )
2495 infot = 6
2496 CALL chpmv( 'U', 0, alpha, a, x, 0, beta, y, 1 )
2497 CALL chkxer( srnamt, infot, nout, lerr, ok )
2498 infot = 9
2499 CALL chpmv( 'U', 0, alpha, a, x, 1, beta, y, 0 )
2500 CALL chkxer( srnamt, infot, nout, lerr, ok )
2501 GO TO 180
2502 60 infot = 1
2503 CALL ctrmv( '/', 'N', 'N', 0, a, 1, x, 1 )
2504 CALL chkxer( srnamt, infot, nout, lerr, ok )
2505 infot = 2
2506 CALL ctrmv( 'U', '/', 'N', 0, a, 1, x, 1 )
2507 CALL chkxer( srnamt, infot, nout, lerr, ok )
2508 infot = 3
2509 CALL ctrmv( 'u', 'n', '/', 0, A, 1, X, 1 )
2510 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2511 INFOT = 4
2512 CALL CTRMV( 'u', 'n', 'n', -1, A, 1, X, 1 )
2513 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2514 INFOT = 6
2515 CALL CTRMV( 'u', 'n', 'n', 2, A, 1, X, 1 )
2516 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2517 INFOT = 8
2518 CALL CTRMV( 'u', 'n', 'n', 0, A, 1, X, 0 )
2519 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2520 GO TO 180
2521 70 INFOT = 1
2522 CALL CTBMV( '/', 'n', 'n', 0, 0, A, 1, X, 1 )
2523 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2524 INFOT = 2
2525 CALL CTBMV( 'u', '/', 'n', 0, 0, A, 1, X, 1 )
2526 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2527 INFOT = 3
2528 CALL CTBMV( 'u', 'n', '/', 0, 0, A, 1, X, 1 )
2529 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2530 INFOT = 4
2531 CALL CTBMV( 'u', 'n', 'n', -1, 0, A, 1, X, 1 )
2532 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2533 INFOT = 5
2534 CALL CTBMV( 'u', 'n', 'n', 0, -1, A, 1, X, 1 )
2535 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2536 INFOT = 7
2537 CALL CTBMV( 'u', 'n', 'n', 0, 1, A, 1, X, 1 )
2538 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2539 INFOT = 9
2540 CALL CTBMV( 'u', 'n', 'N', 0, 0, a, 1, x, 0 )
2541 CALL chkxer( srnamt, infot, nout, lerr, ok )
2542 GO TO 180
2543 80 infot = 1
2544 CALL ctpmv( '/', 'N', 'N', 0, a, x, 1 )
2545 CALL chkxer( srnamt, infot, nout, lerr, ok )
2546 infot = 2
2547 CALL ctpmv( 'U', '/', 'N', 0, a, x, 1 )
2548 CALL chkxer( srnamt, infot, nout, lerr, ok )
2549 infot = 3
2550 CALL ctpmv( 'U', 'N', '/', 0, a, x, 1 )
2551 CALL chkxer( srnamt, infot, nout, lerr, ok )
2552 infot = 4
2553 CALL ctpmv( 'U', 'N', 'N', -1, a, x, 1 )
2554 CALL chkxer( srnamt, infot, nout, lerr, ok )
2555 infot = 7
2556 CALL ctpmv( 'U', 'N', 'N', 0, a, x, 0 )
2557 CALL chkxer( srnamt, infot, nout, lerr, ok )
2558 GO TO 180
2559 90 infot = 1
2560 CALL ctrsv( '/', 'N', 'N', 0, a, 1, x, 1 )
2561 CALL chkxer( srnamt, infot, nout, lerr, ok )
2562 infot = 2
2563 CALL ctrsv( 'U', '/', 'N', 0, a, 1, x, 1 )
2564 CALL chkxer( srnamt, infot, nout, lerr, ok )
2565 infot = 3
2566 CALL ctrsv( 'U', 'N', '/', 0, a, 1, x, 1 )
2567 CALL chkxer( srnamt, infot, nout, lerr, ok )
2568 infot = 4
2569 CALL ctrsv( 'U', 'N', 'N', -1, a, 1, x, 1 )
2570 CALL chkxer( srnamt, infot, nout, lerr, ok )
2571 infot = 6
2572 CALL ctrsv( 'U', 'N', 'N', 2, a, 1, x, 1 )
2573 CALL chkxer( srnamt, infot, nout, lerr, ok )
2574 infot = 8
2575 CALL ctrsv( 'U', 'N', 'N', 0, a, 1, x, 0 )
2576 CALL chkxer( srnamt, infot, nout, lerr, ok )
2577 GO TO 180
2578 100 infot = 1
2579 CALL ctbsv( '/', 'N', 'N', 0, 0, a, 1, x, 1 )
2580 CALL chkxer( srnamt, infot, nout, lerr, ok )
2581 infot = 2
2582 CALL ctbsv( 'U', '/', 'N', 0, 0, a, 1, x, 1 )
2583 CALL chkxer( srnamt, infot, nout, lerr, ok )
2584 infot = 3
2585 CALL ctbsv( 'U', 'N', '/', 0, 0, a, 1, x, 1 )
2586 CALL chkxer( srnamt, infot, nout, lerr, ok )
2587 infot = 4
2588 CALL ctbsv( 'U', 'N', 'N', -1, 0, a, 1, x, 1 )
2589 CALL chkxer( srnamt, infot, nout, lerr, ok )
2590 infot = 5
2591 CALL ctbsv( 'U', 'N', 'N', 0, -1, a, 1, x, 1 )
2592 CALL chkxer( srnamt, infot, nout, lerr, ok )
2593 infot = 7
2594 CALL ctbsv( 'U', 'N', 'N', 0, 1, a, 1, x, 1 )
2595 CALL chkxer( srnamt, infot, nout, lerr, ok )
2596 infot = 9
2597 CALL ctbsv( 'U', 'N', 'N', 0, 0, a, 1, x, 0 )
2598 CALL chkxer( srnamt, infot, nout, lerr, ok )
2599 GO TO 180
2600 110 infot = 1
2601 CALL ctpsv( '/', 'N', 'N', 0, a, x, 1 )
2602 CALL chkxer( srnamt, infot, nout, lerr, ok )
2603 infot = 2
2604 CALL ctpsv( 'U', '/', 'N', 0, a, x, 1 )
2605 CALL chkxer( srnamt, infot, nout, lerr, ok )
2606 infot = 3
2607 CALL ctpsv( 'U', 'N', '/', 0, a, x, 1 )
2608 CALL chkxer( srnamt, infot, nout, lerr, ok )
2609 infot = 4
2610 CALL ctpsv( 'U', 'N', 'N', -1, a, x, 1 )
2611 CALL chkxer( srnamt, infot, nout, lerr, ok )
2612 infot = 7
2613 CALL ctpsv( 'U', 'N', 'N', 0, a, x, 0 )
2614 CALL chkxer( srnamt, infot, nout, lerr, ok )
2615 GO TO 180
2616 120 infot = 1
2617 CALL cgerc( -1, 0, alpha, x, 1, y, 1, a, 1 )
2618 CALL chkxer( srnamt, infot, nout, lerr, ok )
2619 infot = 2
2620 CALL cgerc( 0, -1, alpha, x, 1, y, 1, a, 1 )
2621 CALL chkxer( srnamt, infot, nout, lerr, ok )
2622 infot = 5
2623 CALL cgerc( 0, 0, alpha, x, 0, y, 1, a, 1 )
2624 CALL chkxer( srnamt, infot, nout, lerr, ok )
2625 infot = 7
2626 CALL cgerc( 0, 0, alpha, x, 1, y, 0, a, 1 )
2627 CALL chkxer( srnamt, infot, nout, lerr, ok )
2628 infot = 9
2629 CALL cgerc( 2, 0, alpha, x, 1, y, 1, a, 1 )
2630 CALL chkxer( srnamt, infot, nout, lerr, ok )
2631 GO TO 180
2632 130 infot = 1
2633 CALL cgeru( -1, 0, alpha, x, 1, y, 1, a, 1 )
2634 CALL chkxer( srnamt, infot, nout, lerr, ok )
2635 infot = 2
2636 CALL cgeru( 0, -1, alpha, x, 1, y, 1, a, 1 )
2637 CALL chkxer( srnamt, infot, nout, lerr, ok )
2638 infot = 5
2639 CALL cgeru( 0, 0, alpha, x, 0, y, 1, a, 1 )
2640 CALL chkxer( srnamt, infot, nout, lerr, ok )
2641 infot = 7
2642 CALL cgeru( 0, 0, alpha, x, 1, y, 0, a, 1 )
2643 CALL chkxer( srnamt, infot, nout, lerr, ok )
2644 infot = 9
2645 CALL cgeru( 2, 0, alpha, x, 1, y, 1, a, 1 )
2646 CALL chkxer( srnamt, infot, nout, lerr, ok )
2647 GO TO 180
2648 140 infot = 1
2649 CALL cher( '/', 0, ralpha, x, 1, a, 1 )
2650 CALL chkxer( srnamt, infot, nout, lerr, ok )
2651 infot = 2
2652 CALL cher( 'U', -1, ralpha, x, 1, a, 1 )
2653 CALL chkxer( srnamt, infot, nout, lerr, ok )
2654 infot = 5
2655 CALL cher( 'U', 0, ralpha, x, 0, a, 1 )
2656 CALL chkxer( srnamt, infot, nout, lerr, ok )
2657 infot = 7
2658 CALL cher( 'U', 2, ralpha, x, 1, a, 1 )
2659 CALL chkxer( srnamt, infot, nout, lerr, ok )
2660 GO TO 180
2661 150 infot = 1
2662 CALL chpr( '/', 0, ralpha, x, 1, a )
2663 CALL chkxer( srnamt, infot, nout, lerr, ok )
2664 infot = 2
2665 CALL chpr( 'U', -1, ralpha, x, 1, a )
2666 CALL chkxer( srnamt, infot, nout, lerr, ok )
2667 infot = 5
2668 CALL chpr( 'U', 0, ralpha, x, 0, a )
2669 CALL chkxer( srnamt, infot, nout, lerr, ok )
2670 GO TO 180
2671 160 infot = 1
2672 CALL cher2( '/', 0, alpha, x, 1, y, 1, a, 1 )
2673 CALL chkxer( srnamt, infot, nout, lerr, ok )
2674 infot = 2
2675 CALL cher2( 'U', -1, alpha, x, 1, y, 1, a, 1 )
2676 CALL chkxer( srnamt, infot, nout, lerr, ok )
2677 infot = 5
2678 CALL cher2( 'U', 0, alpha, x, 0, y, 1, a, 1 )
2679 CALL chkxer( srnamt, infot, nout, lerr, ok )
2680 infot = 7
2681 CALL cher2( 'U', 0, alpha, x, 1, y, 0, a, 1 )
2682 CALL chkxer( srnamt, infot, nout, lerr, ok )
2683 infot = 9
2684 CALL cher2( 'U', 2, alpha, x, 1, y, 1, a, 1 )
2685 CALL chkxer( srnamt, infot, nout, lerr, ok )
2686 GO TO 180
2687 170 infot = 1
2688 CALL chpr2( '/', 0, alpha, x, 1, y, 1, a )
2689 CALL chkxer( srnamt, infot, nout, lerr, ok )
2690 infot = 2
2691 CALL chpr2( 'U', -1, alpha, x, 1, y, 1, a )
2692 CALL chkxer( srnamt, infot, nout, lerr, ok )
2693 infot = 5
2694 CALL chpr2( 'U', 0, alpha, x, 0, y, 1, a )
2695 CALL chkxer( srnamt, infot, nout, lerr, ok )
2696 infot = 7
2697 CALL chpr2( 'U', 0, alpha, x, 1, y, 0, a )
2698 CALL chkxer( srnamt, infot, nout, lerr, ok )
2699*
2700 180 IF( ok )THEN
2701 WRITE( nout, fmt = 9999 )srnamt
2702 ELSE
2703 WRITE( nout, fmt = 9998 )srnamt
2704 END IF
2705 RETURN
2706*
2707 9999 FORMAT( ' ', a6, ' PASSED THE TESTS OF ERROR-EXITS' )
2708 9998 FORMAT( ' ******* ', a6, ' FAILED THE TESTS OF ERROR-EXITS *****',
2709 $ '**' )
2710*
2711* End of CCHKE
2712*
2713 END
2714 SUBROUTINE cmake( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
2715 $ KU, RESET, TRANSL )
2716*
2717* Generates values for an M by N matrix A within the bandwidth
2718* defined by KL and KU.
2719* Stores the values in the array AA in the data structure required
2720* by the routine, with unwanted elements set to rogue value.
2721*
2722* TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'.
2723*
2724* Auxiliary routine for test program for Level 2 Blas.
2725*
2726* -- Written on 10-August-1987.
2727* Richard Hanson, Sandia National Labs.
2728* Jeremy Du Croz, NAG Central Office.
2729*
2730* .. Parameters ..
2731 COMPLEX ZERO, ONE
2732 PARAMETER ( ZERO = ( 0.0, 0.0 ), one = ( 1.0, 0.0 ) )
2733 COMPLEX ROGUE
2734 PARAMETER ( ROGUE = ( -1.0e10, 1.0e10 ) )
2735 REAL RZERO
2736 PARAMETER ( RZERO = 0.0 )
2737 real rrogue
2738 parameter( rrogue = -1.0e10 )
2739* .. Scalar Arguments ..
2740 COMPLEX TRANSL
2741 INTEGER KL, KU, LDA, M, N, NMAX
2742 LOGICAL RESET
2743 CHARACTER*1 DIAG, UPLO
2744 CHARACTER*2 TYPE
2745* .. Array Arguments ..
2746 COMPLEX A( NMAX, * ), AA( * )
2747* .. Local Scalars ..
2748 INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK
2749 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2750* .. External Functions ..
2751 COMPLEX CBEG
2752 EXTERNAL CBEG
2753* .. Intrinsic Functions ..
2754 INTRINSIC cmplx, conjg, max, min, real
2755* .. Executable Statements ..
2756 gen = TYPE( 1: 1 ).EQ.'G'
2757 sym = TYPE( 1: 1 ).EQ.'H'
2758 TRI = type( 1: 1 ).EQ.'T'
2759 upper = ( sym.OR.tri ).AND.uplo.EQ.'U'
2760 lower = ( sym.OR.tri ).AND.uplo.EQ.'L'
2761 unit = tri.AND.diag.EQ.'U'
2762*
2763* Generate data in array A.
2764*
2765 DO 20 j = 1, n
2766 DO 10 i = 1, m
2767 IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
2768 $ THEN
2769 IF( ( i.LE.j.AND.j - i.LE.ku ).OR.
2770 $ ( i.GE.j.AND.i - j.LE.kl ) )THEN
2771 a( i, j ) = cbeg( reset ) + transl
2772 ELSE
2773 a( i, j ) = zero
2774 END IF
2775 IF( i.NE.j )THEN
2776 IF( sym )THEN
2777 a( j, i ) = conjg( a( i, j ) )
2778 ELSE IF( tri )THEN
2779 a( j, i ) = zero
2780 END IF
2781 END IF
2782 END IF
2783 10 CONTINUE
2784 IF( sym )
2785 $ a( j, j ) = cmplx( real( a( j, j ) ), rzero )
2786 IF( tri )
2787 $ a( j, j ) = a( j, j ) + one
2788 IF( unit )
2789 $ a( j, j ) = one
2790 20 CONTINUE
2791*
2792* Store elements in array AS in data structure required by routine.
2793*
2794 IF( type.EQ.'GE' )THEN
2795 DO 50 j = 1, n
2796 DO 30 i = 1, m
2797 aa( i + ( j - 1 )*lda ) = a( i, j )
2798 30 CONTINUE
2799 DO 40 i = m + 1, lda
2800 aa( i + ( j - 1 )*lda ) = rogue
2801 40 CONTINUE
2802 50 CONTINUE
2803 ELSE IF( type.EQ.'GB' )THEN
2804 DO 90 j = 1, n
2805 DO 60 i1 = 1, ku + 1 - j
2806 aa( i1 + ( j - 1 )*lda ) = rogue
2807 60 CONTINUE
2808 DO 70 i2 = i1, min( kl + ku + 1, ku + 1 + m - j )
2809 aa( i2 + ( j - 1 )*lda ) = a( i2 + j - ku - 1, j )
2810 70 CONTINUE
2811 DO 80 i3 = i2, lda
2812 aa( i3 + ( j - 1 )*lda ) = rogue
2813 80 CONTINUE
2814 90 CONTINUE
2815 ELSE IF( type.EQ.'HE'.OR.type.EQ.'TR' )THEN
2816 DO 130 j = 1, n
2817 IF( upper )THEN
2818 ibeg = 1
2819 IF( unit )THEN
2820 iend = j - 1
2821 ELSE
2822 iend = j
2823 END IF
2824 ELSE
2825 IF( unit )THEN
2826 ibeg = j + 1
2827 ELSE
2828 ibeg = j
2829 END IF
2830 iend = n
2831 END IF
2832 DO 100 i = 1, ibeg - 1
2833 aa( i + ( j - 1 )*lda ) = rogue
2834 100 CONTINUE
2835 DO 110 i = ibeg, iend
2836 aa( i + ( j - 1 )*lda ) = a( i, j )
2837 110 CONTINUE
2838 DO 120 i = iend + 1, lda
2839 aa( i + ( j - 1 )*lda ) = rogue
2840 120 CONTINUE
2841 IF( sym )THEN
2842 jj = j + ( j - 1 )*lda
2843 aa( jj ) = cmplx( real( aa( jj ) ), rrogue )
2844 END IF
2845 130 CONTINUE
2846 ELSE IF( type.EQ.'HB'.OR.type.EQ.'TB' )THEN
2847 DO 170 j = 1, n
2848 IF( upper )THEN
2849 kk = kl + 1
2850 ibeg = max( 1, kl + 2 - j )
2851 IF( unit )THEN
2852 iend = kl
2853 ELSE
2854 iend = kl + 1
2855 END IF
2856 ELSE
2857 kk = 1
2858 IF( unit )THEN
2859 ibeg = 2
2860 ELSE
2861 ibeg = 1
2862 END IF
2863 iend = min( kl + 1, 1 + m - j )
2864 END IF
2865 DO 140 i = 1, ibeg - 1
2866 aa( i + ( j - 1 )*lda ) = rogue
2867 140 CONTINUE
2868 DO 150 i = ibeg, iend
2869 aa( i + ( j - 1 )*lda ) = a( i + j - kk, j )
2870 150 CONTINUE
2871 DO 160 i = iend + 1, lda
2872 aa( i + ( j - 1 )*lda ) = rogue
2873 160 CONTINUE
2874 IF( sym )THEN
2875 jj = kk + ( j - 1 )*lda
2876 aa( jj ) = cmplx( real( aa( jj ) ), rrogue )
2877 END IF
2878 170 CONTINUE
2879 ELSE IF( type.EQ.'HP'.OR.type.EQ.'TP' )THEN
2880 ioff = 0
2881 DO 190 j = 1, n
2882 IF( upper )THEN
2883 ibeg = 1
2884 iend = j
2885 ELSE
2886 ibeg = j
2887 iend = n
2888 END IF
2889 DO 180 i = ibeg, iend
2890 ioff = ioff + 1
2891 aa( ioff ) = a( i, j )
2892 IF( i.EQ.j )THEN
2893 IF( unit )
2894 $ aa( ioff ) = rogue
2895 IF( sym )
2896 $ aa( ioff ) = cmplx( real( aa( ioff ) ), rrogue )
2897 END IF
2898 180 CONTINUE
2899 190 CONTINUE
2900 END IF
2901 RETURN
2902*
2903* End of CMAKE
2904*
2905 END
2906 SUBROUTINE cmvch( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
2907 $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
2908*
2909* Checks the results of the computational tests.
2910*
2911* Auxiliary routine for test program for Level 2 Blas.
2912*
2913* -- Written on 10-August-1987.
2914* Richard Hanson, Sandia National Labs.
2915* Jeremy Du Croz, NAG Central Office.
2916*
2917* .. Parameters ..
2918 COMPLEX ZERO
2919 parameter( zero = ( 0.0, 0.0 ) )
2920 REAL RZERO, RONE
2921 PARAMETER ( RZERO = 0.0, rone = 1.0 )
2922* .. Scalar Arguments ..
2923 COMPLEX ALPHA, BETA
2924 REAL EPS, ERR
2925 INTEGER INCX, INCY, M, N, NMAX, NOUT
2926 LOGICAL FATAL, MV
2927 CHARACTER*1 TRANS
2928* .. Array Arguments ..
2929 COMPLEX A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * )
2930 REAL G( * )
2931* .. Local Scalars ..
2932 COMPLEX C
2933 REAL ERRI
2934 INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
2935 LOGICAL CTRAN, TRAN
2936* .. Intrinsic Functions ..
2937 INTRINSIC abs, aimag, conjg, max, real, sqrt
2938* .. Statement Functions ..
2939 REAL ABS1
2940* .. Statement Function definitions ..
2941 abs1( c ) = abs( real( c ) ) + abs( aimag( c ) )
2942* .. Executable Statements ..
2943 tran = trans.EQ.'T'
2944 ctran = trans.EQ.'C'
2945 IF( tran.OR.ctran )THEN
2946 ml = n
2947 nl = m
2948 ELSE
2949 ml = m
2950 nl = n
2951 END IF
2952 IF( incx.LT.0 )THEN
2953 kx = nl
2954 incxl = -1
2955 ELSE
2956 kx = 1
2957 incxl = 1
2958 END IF
2959 IF( incy.LT.0 )THEN
2960 ky = ml
2961 incyl = -1
2962 ELSE
2963 ky = 1
2964 incyl = 1
2965 END IF
2966*
2967* Compute expected result in YT using data in A, X and Y.
2968* Compute gauges in G.
2969*
2970 iy = ky
2971 DO 40 i = 1, ml
2972 yt( iy ) = zero
2973 g( iy ) = rzero
2974 jx = kx
2975 IF( tran )THEN
2976 DO 10 j = 1, nl
2977 yt( iy ) = yt( iy ) + a( j, i )*x( jx )
2978 g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
2979 jx = jx + incxl
2980 10 CONTINUE
2981 ELSE IF( ctran )THEN
2982 DO 20 j = 1, nl
2983 yt( iy ) = yt( iy ) + conjg( a( j, i ) )*x( jx )
2984 g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
2985 jx = jx + incxl
2986 20 CONTINUE
2987 ELSE
2988 DO 30 j = 1, nl
2989 yt( iy ) = yt( iy ) + a( i, j )*x( jx )
2990 g( iy ) = g( iy ) + abs1( a( i, j ) )*abs1( x( jx ) )
2991 jx = jx + incxl
2992 30 CONTINUE
2993 END IF
2994 yt( iy ) = alpha*yt( iy ) + beta*y( iy )
2995 g( iy ) = abs1( alpha )*g( iy ) + abs1( beta )*abs1( y( iy ) )
2996 iy = iy + incyl
2997 40 CONTINUE
2998*
2999* Compute the error ratio for this result.
3000*
3001 err = zero
3002 DO 50 i = 1, ml
3003 erri = abs( yt( i ) - yy( 1 + ( i - 1 )*abs( incy ) ) )/eps
3004 IF( g( i ).NE.rzero )
3005 $ erri = erri/g( i )
3006 err = max( err, erri )
3007 IF( err*sqrt( eps ).GE.rone )
3008 $ GO TO 60
3009 50 CONTINUE
3010* If the loop completes, all results are at least half accurate.
3011 GO TO 80
3012*
3013* Report fatal error.
3014*
3015 60 fatal = .true.
3016 WRITE( nout, fmt = 9999 )
3017 DO 70 i = 1, ml
3018 IF( mv )THEN
3019 WRITE( nout, fmt = 9998 )i, yt( i ),
3020 $ yy( 1 + ( i - 1 )*abs( incy ) )
3021 ELSE
3022 WRITE( nout, fmt = 9998 )i,
3023 $ yy( 1 + ( i - 1 )*abs( incy ) ), yt( i )
3024 END IF
3025 70 CONTINUE
3026*
3027 80 CONTINUE
3028 RETURN
3029*
3030 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3031 $ 'F ACCURATE *******', /' EXPECTED RE',
3032 $ 'SULT COMPUTED RESULT' )
3033 9998 FORMAT( 1x, i7, 2( ' (', g15.6, ',', g15.6, ')' ) )
3034*
3035* End of CMVCH
3036*
3037 END
3038 LOGICAL FUNCTION lce( RI, RJ, LR )
3039*
3040* Tests if two arrays are identical.
3041*
3042* Auxiliary routine for test program for Level 2 Blas.
3043*
3044* -- Written on 10-August-1987.
3045* Richard Hanson, Sandia National Labs.
3046* Jeremy Du Croz, NAG Central Office.
3047*
3048* .. Scalar Arguments ..
3049 INTEGER lr
3050* .. Array Arguments ..
3051 COMPLEX ri( * ), rj( * )
3052* .. Local Scalars ..
3053 INTEGER i
3054* .. Executable Statements ..
3055 do 10 i = 1, lr
3056 IF( ri( i ).NE.rj( i ) )
3057 $ GO TO 20
3058 10 CONTINUE
3059 lce = .true.
3060 GO TO 30
3061 20 CONTINUE
3062 lce = .false.
3063 30 RETURN
3064*
3065* End of LCE
3066*
3067 END
3068 LOGICAL FUNCTION lceres( TYPE, UPLO, M, N, AA, AS, LDA )
3069*
3070* Tests if selected elements in two arrays are equal.
3071*
3072* TYPE is 'GE', 'HE' or 'HP'.
3073*
3074* Auxiliary routine for test program for Level 2 Blas.
3075*
3076* -- Written on 10-August-1987.
3077* Richard Hanson, Sandia National Labs.
3078* Jeremy Du Croz, NAG Central Office.
3079*
3080* .. Scalar Arguments ..
3081 INTEGER lda, m, n
3082 CHARACTER*1 uplo
3083 CHARACTER*2 type
3084* .. Array Arguments ..
3085 COMPLEX aa( lda, * ), as( lda, * )
3086* .. Local Scalars ..
3087 INTEGER i, ibeg, iend, j
3088 LOGICAL upper
3089* .. Executable Statements ..
3090 upper = uplo.EQ.'U'
3091 IF( type.EQ.'GE' )THEN
3092 DO 20 j = 1, n
3093 DO 10 i = m + 1, lda
3094 IF( aa( i, j ).NE.as( i, j ) )
3095 $ GO TO 70
3096 10 CONTINUE
3097 20 CONTINUE
3098 ELSE IF( type.EQ.'HE' )THEN
3099 DO 50 j = 1, n
3100 IF( upper )THEN
3101 ibeg = 1
3102 iend = j
3103 ELSE
3104 ibeg = j
3105 iend = n
3106 END IF
3107 DO 30 i = 1, ibeg - 1
3108 IF( aa( i, j ).NE.as( i, j ) )
3109 $ GO TO 70
3110 30 CONTINUE
3111 DO 40 i = iend + 1, lda
3112 IF( aa( i, j ).NE.as( i, j ) )
3113 $ GO TO 70
3114 40 CONTINUE
3115 50 CONTINUE
3116 END IF
3117*
3118 lceres = .true.
3119 GO TO 80
3120 70 CONTINUE
3121 lceres = .false.
3122 80 RETURN
3123*
3124* End of LCERES
3125*
3126 END
3127 COMPLEX FUNCTION cbeg( RESET )
3128*
3129* Generates complex numbers as pairs of random numbers uniformly
3130* distributed between -0.5 and 0.5.
3131*
3132* Auxiliary routine for test program for Level 2 Blas.
3133*
3134* -- Written on 10-August-1987.
3135* Richard Hanson, Sandia National Labs.
3136* Jeremy Du Croz, NAG Central Office.
3137*
3138* .. Scalar Arguments ..
3139 LOGICAL reset
3140* .. Local Scalars ..
3141 INTEGER i, ic, j, mi, mj
3142* .. Save statement ..
3143 SAVE i, ic, j, mi, mj
3144* .. Intrinsic Functions ..
3145 INTRINSIC cmplx
3146* .. Executable Statements ..
3147 if( reset )then
3148* Initialize local variables.
3149 mi = 891
3150 mj = 457
3151 i = 7
3152 j = 7
3153 ic = 0
3154 reset = .false.
3155 END IF
3156*
3157* The sequence of values of I or J is bounded between 1 and 999.
3158* If initial I or J = 1,2,3,6,7 or 9, the period will be 50.
3159* If initial I or J = 4 or 8, the period will be 25.
3160* If initial I or J = 5, the period will be 10.
3161* IC is used to break up the period by skipping 1 value of I or J
3162* in 6.
3163*
3164 ic = ic + 1
3165 10 i = i*mi
3166 j = j*mj
3167 i = i - 1000*( i/1000 )
3168 j = j - 1000*( j/1000 )
3169 IF( ic.GE.5 )THEN
3170 ic = 0
3171 GO TO 10
3172 END IF
3173 cbeg = cmplx( ( i - 500 )/1001.0, ( j - 500 )/1001.0 )
3174 RETURN
3175*
3176* End of CBEG
3177*
3178 END
3179 REAL function sdiff( x, y )
3180*
3181* Auxiliary routine for test program for Level 2 Blas.
3182*
3183* -- Written on 10-August-1987.
3184* Richard Hanson, Sandia National Labs.
3185*
3186* .. Scalar Arguments ..
3187 REAL x, y
3188* .. Executable Statements ..
3189 sdiff = x - y
3190 RETURN
3191*
3192* End of SDIFF
3193*
3194 END
3195 SUBROUTINE chkxer( SRNAMT, INFOT, NOUT, LERR, OK )
3196*
3197* Tests whether XERBLA has detected an error when it should.
3198*
3199* Auxiliary routine for test program for Level 2 Blas.
3200*
3201* -- Written on 10-August-1987.
3202* Richard Hanson, Sandia National Labs.
3203* Jeremy Du Croz, NAG Central Office.
3204*
3205* .. Scalar Arguments ..
3206 INTEGER INFOT, NOUT
3207 LOGICAL LERR, OK
3208 CHARACTER*6 SRNAMT
3209* .. Executable Statements ..
3210 IF( .NOT.lerr )THEN
3211 WRITE( nout, fmt = 9999 )infot, srnamt
3212 ok = .false.
3213 END IF
3214 lerr = .false.
3215 RETURN
3216*
3217 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', i2, ' NOT D',
3218 $ 'ETECTED BY ', a6, ' *****' )
3219*
3220* End of CHKXER
3221*
3222 END
3223 SUBROUTINE xerbla( SRNAME, INFO )
3224*
3225* This is a special version of XERBLA to be used only as part of
3226* the test program for testing error exits from the Level 2 BLAS
3227* routines.
3228*
3229* XERBLA is an error handler for the Level 2 BLAS routines.
3230*
3231* It is called by the Level 2 BLAS routines if an input parameter is
3232* invalid.
3233*
3234* Auxiliary routine for test program for Level 2 Blas.
3235*
3236* -- Written on 10-August-1987.
3237* Richard Hanson, Sandia National Labs.
3238* Jeremy Du Croz, NAG Central Office.
3239*
3240* .. Scalar Arguments ..
3241 INTEGER INFO
3242 CHARACTER*6 SRNAME
3243* .. Scalars in Common ..
3244 INTEGER INFOT, NOUT
3245 LOGICAL LERR, OK
3246 CHARACTER*6 SRNAMT
3247* .. Common blocks ..
3248 COMMON /INFOC/INFOT, NOUT, OK, LERR
3249 COMMON /SRNAMC/SRNAMT
3250* .. Executable Statements ..
3251 LERR = .true.
3252 IF( info.NE.infot )THEN
3253 IF( infot.NE.0 )THEN
3254 WRITE( nout, fmt = 9999 )info, infot
3255 ELSE
3256 WRITE( nout, fmt = 9997 )info
3257 END IF
3258 ok = .false.
3259 END IF
3260 IF( srname.NE.srnamt )THEN
3261 WRITE( nout, fmt = 9998 )srname, srnamt
3262 ok = .false.
3263 END IF
3264 RETURN
3265*
3266 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', i6, ' INSTEAD',
3267 $ ' OF ', i2, ' *******' )
3268 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', a6, ' INSTE',
3269 $ 'AD OF ', a6, ' *******' )
3270 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', i6,
3271 $ ' *******' )
3272*
3273* End of XERBLA
3274*
3275 END
cmplx
float cmplx[2]
Definition pblas.h:136
cmake
subroutine cmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition cblat2.f:2716
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:1769
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:783
sdiff
real function sdiff(x, y)
Definition cblat2.f:3180
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:2053
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
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3224
lceres
logical function lceres(type, uplo, m, n, aa, as, lda)
Definition cblat2.f:3069
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:2908
lce
logical function lce(ri, rj, lr)
Definition cblat2.f:3039
cchke
subroutine cchke(isnum, srnamt, nout)
Definition cblat2.f:2372
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:1492
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:1130
cbeg
complex function cbeg(reset)
Definition cblat2.f:3128
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3196
if
if(complex_arithmetic) id
the
end diagonal values have been computed in the(sparse) matrix id.SOL
alpha
#define alpha
Definition eval.h:35
ctrmv
subroutine ctrmv(uplo, trans, diag, n, a, lda, x, incx)
CTRMV
Definition ctrmv.f:147
chemv
subroutine chemv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
CHEMV
Definition chemv.f:154
cgbmv
subroutine cgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
CGBMV
Definition cgbmv.f:187
ctpmv
subroutine ctpmv(uplo, trans, diag, n, ap, x, incx)
CTPMV
Definition ctpmv.f:142
cgemv
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
Definition cgemv.f:158
ctbmv
subroutine ctbmv(uplo, trans, diag, n, k, a, lda, x, incx)
CTBMV
Definition ctbmv.f:186
chpr2
subroutine chpr2(uplo, n, alpha, x, incx, y, incy, ap)
CHPR2
Definition chpr2.f:145
ctpsv
subroutine ctpsv(uplo, trans, diag, n, ap, x, incx)
CTPSV
Definition ctpsv.f:144
chpmv
subroutine chpmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
CHPMV
Definition chpmv.f:149
ctbsv
subroutine ctbsv(uplo, trans, diag, n, k, a, lda, x, incx)
CTBSV
Definition ctbsv.f:189
chpr
subroutine chpr(uplo, n, alpha, x, incx, ap)
CHPR
Definition chpr.f:130
ctrsv
subroutine ctrsv(uplo, trans, diag, n, a, lda, x, incx)
CTRSV
Definition ctrsv.f:149
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
cher
subroutine cher(uplo, n, alpha, x, incx, a, lda)
CHER
Definition cher.f:135
chbmv
subroutine chbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
CHBMV
Definition chbmv.f:187
cher2
subroutine cher2(uplo, n, alpha, x, incx, y, incy, a, lda)
CHER2
Definition cher2.f:150
cblat2
program cblat2
CBLAT2
Definition cblat2.f:102
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
nl
character *2 function nl()
Definition message.F:2354
fatal
void fatal(char *msg)
Definition sys_pipes_c.c:76