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