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