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