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