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