• Home
  • Line#
  • Scopes#
  • Navigate#
  • Raw
  • Download
1      PROGRAM CBLAT3
2*
3*  Test program for the COMPLEX          Level 3 Blas.
4*
5*  The program must be driven by a short data file. The first 13 records
6*  of the file are read using list-directed input, the last 9 records
7*  are read using the format ( A12, L2 ). An annotated example of a data
8*  file can be obtained by deleting the first 3 characters from the
9*  following 22 lines:
10*  'CBLAT3.SNAP'     NAME OF SNAPSHOT OUTPUT FILE
11*  -1                UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
12*  F        LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
13*  F        LOGICAL FLAG, T TO STOP ON FAILURES.
14*  T        LOGICAL FLAG, T TO TEST ERROR EXITS.
15*  2        0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH
16*  16.0     THRESHOLD VALUE OF TEST RATIO
17*  6                 NUMBER OF VALUES OF N
18*  0 1 2 3 5 9       VALUES OF N
19*  3                 NUMBER OF VALUES OF ALPHA
20*  (0.0,0.0) (1.0,0.0) (0.7,-0.9)       VALUES OF ALPHA
21*  3                 NUMBER OF VALUES OF BETA
22*  (0.0,0.0) (1.0,0.0) (1.3,-1.1)       VALUES OF BETA
23*  cblas_cgemm  T PUT F FOR NO TEST. SAME COLUMNS.
24*  cblas_chemm  T PUT F FOR NO TEST. SAME COLUMNS.
25*  cblas_csymm  T PUT F FOR NO TEST. SAME COLUMNS.
26*  cblas_ctrmm  T PUT F FOR NO TEST. SAME COLUMNS.
27*  cblas_ctrsm  T PUT F FOR NO TEST. SAME COLUMNS.
28*  cblas_cherk  T PUT F FOR NO TEST. SAME COLUMNS.
29*  cblas_csyrk  T PUT F FOR NO TEST. SAME COLUMNS.
30*  cblas_cher2k T PUT F FOR NO TEST. SAME COLUMNS.
31*  cblas_csyr2k T PUT F FOR NO TEST. SAME COLUMNS.
32*
33*  See:
34*
35*     Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
36*     A Set of Level 3 Basic Linear Algebra Subprograms.
37*
38*     Technical Memorandum No.88 (Revision 1), Mathematics and
39*     Computer Science Division, Argonne National Laboratory, 9700
40*     South Cass Avenue, Argonne, Illinois 60439, US.
41*
42*  -- Written on 8-February-1989.
43*     Jack Dongarra, Argonne National Laboratory.
44*     Iain Duff, AERE Harwell.
45*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
46*     Sven Hammarling, Numerical Algorithms Group Ltd.
47*
48*     .. Parameters ..
49      INTEGER            NIN, NOUT
50      PARAMETER          ( NIN = 5, NOUT = 6 )
51      INTEGER            NSUBS
52      PARAMETER          ( NSUBS = 9 )
53      COMPLEX            ZERO, ONE
54      PARAMETER          ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
55      REAL               RZERO, RHALF, RONE
56      PARAMETER          ( RZERO = 0.0, RHALF = 0.5, RONE = 1.0 )
57      INTEGER            NMAX
58      PARAMETER          ( NMAX = 65 )
59      INTEGER            NIDMAX, NALMAX, NBEMAX
60      PARAMETER          ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 )
61*     .. Local Scalars ..
62      REAL               EPS, ERR, THRESH
63      INTEGER            I, ISNUM, J, N, NALF, NBET, NIDIM, NTRA,
64     $                   LAYOUT
65      LOGICAL            FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
66     $                   TSTERR, CORDER, RORDER
67      CHARACTER*1        TRANSA, TRANSB
68      CHARACTER*12       SNAMET
69      CHARACTER*32       SNAPS
70*     .. Local Arrays ..
71      COMPLEX            AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
72     $                   ALF( NALMAX ), AS( NMAX*NMAX ),
73     $                   BB( NMAX*NMAX ), BET( NBEMAX ),
74     $                   BS( NMAX*NMAX ), C( NMAX, NMAX ),
75     $                   CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
76     $                   W( 2*NMAX )
77      REAL               G( NMAX )
78      INTEGER            IDIM( NIDMAX )
79      LOGICAL            LTEST( NSUBS )
80      CHARACTER*12       SNAMES( NSUBS )
81*     .. External Functions ..
82      REAL               SDIFF
83      LOGICAL            LCE
84      EXTERNAL           SDIFF, LCE
85*     .. External Subroutines ..
86      EXTERNAL         CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CMMCH
87*     .. Intrinsic Functions ..
88      INTRINSIC          MAX, MIN
89*     .. Scalars in Common ..
90      INTEGER            INFOT, NOUTC
91      LOGICAL            LERR, OK
92      CHARACTER*12       SRNAMT
93*     .. Common blocks ..
94      COMMON             /INFOC/INFOT, NOUTC, OK, LERR
95      COMMON             /SRNAMC/SRNAMT
96*     .. Data statements ..
97      DATA               SNAMES/'cblas_cgemm ', 'cblas_chemm ',
98     $                   'cblas_csymm ', 'cblas_ctrmm ', 'cblas_ctrsm ',
99     $                   'cblas_cherk ', 'cblas_csyrk ', 'cblas_cher2k',
100     $                   'cblas_csyr2k'/
101*     .. Executable Statements ..
102*
103      NOUTC = NOUT
104*
105*     Read name and unit number for snapshot output file and open file.
106*
107      READ( NIN, FMT = * )SNAPS
108      READ( NIN, FMT = * )NTRA
109      TRACE = NTRA.GE.0
110      IF( TRACE )THEN
111         OPEN( NTRA, FILE = SNAPS )
112      END IF
113*     Read the flag that directs rewinding of the snapshot file.
114      READ( NIN, FMT = * )REWI
115      REWI = REWI.AND.TRACE
116*     Read the flag that directs stopping on any failure.
117      READ( NIN, FMT = * )SFATAL
118*     Read the flag that indicates whether error exits are to be tested.
119      READ( NIN, FMT = * )TSTERR
120*     Read the flag that indicates whether row-major data layout to be tested.
121      READ( NIN, FMT = * )LAYOUT
122*     Read the threshold value of the test ratio
123      READ( NIN, FMT = * )THRESH
124*
125*     Read and check the parameter values for the tests.
126*
127*     Values of N
128      READ( NIN, FMT = * )NIDIM
129      IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
130         WRITE( NOUT, FMT = 9997 )'N', NIDMAX
131         GO TO 220
132      END IF
133      READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
134      DO 10 I = 1, NIDIM
135         IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
136            WRITE( NOUT, FMT = 9996 )NMAX
137            GO TO 220
138         END IF
139   10 CONTINUE
140*     Values of ALPHA
141      READ( NIN, FMT = * )NALF
142      IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
143         WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
144         GO TO 220
145      END IF
146      READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
147*     Values of BETA
148      READ( NIN, FMT = * )NBET
149      IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
150         WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
151         GO TO 220
152      END IF
153      READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
154*
155*     Report values of parameters.
156*
157      WRITE( NOUT, FMT = 9995 )
158      WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM )
159      WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF )
160      WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET )
161      IF( .NOT.TSTERR )THEN
162         WRITE( NOUT, FMT = * )
163         WRITE( NOUT, FMT = 9984 )
164      END IF
165      WRITE( NOUT, FMT = * )
166      WRITE( NOUT, FMT = 9999 )THRESH
167      WRITE( NOUT, FMT = * )
168
169      RORDER = .FALSE.
170      CORDER = .FALSE.
171      IF (LAYOUT.EQ.2) THEN
172         RORDER = .TRUE.
173         CORDER = .TRUE.
174         WRITE( *, FMT = 10002 )
175      ELSE IF (LAYOUT.EQ.1) THEN
176         RORDER = .TRUE.
177         WRITE( *, FMT = 10001 )
178      ELSE IF (LAYOUT.EQ.0) THEN
179         CORDER = .TRUE.
180         WRITE( *, FMT = 10000 )
181      END IF
182      WRITE( *, FMT = * )
183
184*
185*     Read names of subroutines and flags which indicate
186*     whether they are to be tested.
187*
188      DO 20 I = 1, NSUBS
189         LTEST( I ) = .FALSE.
190   20 CONTINUE
191   30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT
192      DO 40 I = 1, NSUBS
193         IF( SNAMET.EQ.SNAMES( I ) )
194     $      GO TO 50
195   40 CONTINUE
196      WRITE( NOUT, FMT = 9990 )SNAMET
197      STOP
198   50 LTEST( I ) = LTESTT
199      GO TO 30
200*
201   60 CONTINUE
202      CLOSE ( NIN )
203*
204*     Compute EPS (the machine precision).
205*
206      EPS = RONE
207   70 CONTINUE
208      IF( SDIFF( RONE + EPS, RONE ).EQ.RZERO )
209     $   GO TO 80
210      EPS = RHALF*EPS
211      GO TO 70
212   80 CONTINUE
213      EPS = EPS + EPS
214      WRITE( NOUT, FMT = 9998 )EPS
215*
216*     Check the reliability of CMMCH using exact data.
217*
218      N = MIN( 32, NMAX )
219      DO 100 J = 1, N
220         DO 90 I = 1, N
221            AB( I, J ) = MAX( I - J + 1, 0 )
222   90    CONTINUE
223         AB( J, NMAX + 1 ) = J
224         AB( 1, NMAX + J ) = J
225         C( J, 1 ) = ZERO
226  100 CONTINUE
227      DO 110 J = 1, N
228         CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
229  110 CONTINUE
230*     CC holds the exact result. On exit from CMMCH CT holds
231*     the result computed by CMMCH.
232      TRANSA = 'N'
233      TRANSB = 'N'
234      CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
235     $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
236     $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
237      SAME = LCE( CC, CT, N )
238      IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
239         WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
240         STOP
241      END IF
242      TRANSB = 'C'
243      CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
244     $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
245     $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
246      SAME = LCE( CC, CT, N )
247      IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
248         WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
249         STOP
250      END IF
251      DO 120 J = 1, N
252         AB( J, NMAX + 1 ) = N - J + 1
253         AB( 1, NMAX + J ) = N - J + 1
254  120 CONTINUE
255      DO 130 J = 1, N
256         CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 -
257     $                     ( ( J + 1 )*J*( J - 1 ) )/3
258  130 CONTINUE
259      TRANSA = 'C'
260      TRANSB = 'N'
261      CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
262     $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
263     $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
264      SAME = LCE( CC, CT, N )
265      IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
266         WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
267         STOP
268      END IF
269      TRANSB = 'C'
270      CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
271     $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
272     $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
273      SAME = LCE( CC, CT, N )
274      IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
275         WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
276         STOP
277      END IF
278*
279*     Test each subroutine in turn.
280*
281      DO 200 ISNUM = 1, NSUBS
282         WRITE( NOUT, FMT = * )
283         IF( .NOT.LTEST( ISNUM ) )THEN
284*           Subprogram is not to be tested.
285            WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM )
286         ELSE
287            SRNAMT = SNAMES( ISNUM )
288*           Test error exits.
289            IF( TSTERR )THEN
290               CALL CC3CHKE( SNAMES( ISNUM ) )
291               WRITE( NOUT, FMT = * )
292            END IF
293*           Test computations.
294            INFOT = 0
295            OK = .TRUE.
296            FATAL = .FALSE.
297            GO TO ( 140, 150, 150, 160, 160, 170, 170,
298     $              180, 180 )ISNUM
299*           Test CGEMM, 01.
300  140       IF (CORDER) THEN
301            CALL CCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
302     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
303     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
304     $                 CC, CS, CT, G, 0 )
305            END IF
306            IF (RORDER) THEN
307            CALL CCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
308     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
309     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
310     $                 CC, CS, CT, G, 1 )
311            END IF
312            GO TO 190
313*           Test CHEMM, 02, CSYMM, 03.
314  150       IF (CORDER) THEN
315            CALL CCHK2(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
316     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
317     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
318     $                 CC, CS, CT, G, 0 )
319            END IF
320            IF (RORDER) THEN
321            CALL CCHK2(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
322     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
323     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
324     $                 CC, CS, CT, G, 1 )
325            END IF
326            GO TO 190
327*           Test CTRMM, 04, CTRSM, 05.
328  160       IF (CORDER) THEN
329            CALL CCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
330     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
331     $                 AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C,
332     $		0 )
333            END IF
334            IF (RORDER) THEN
335            CALL CCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
336     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
337     $                 AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C,
338     $		1 )
339            END IF
340            GO TO 190
341*           Test CHERK, 06, CSYRK, 07.
342  170       IF (CORDER) THEN
343            CALL CCHK4(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
344     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
345     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
346     $                 CC, CS, CT, G, 0 )
347            END IF
348            IF (RORDER) THEN
349            CALL CCHK4(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
350     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
351     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
352     $                 CC, CS, CT, G, 1 )
353            END IF
354            GO TO 190
355*           Test CHER2K, 08, CSYR2K, 09.
356  180       IF (CORDER) THEN
357            CALL CCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
358     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
359     $                 NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
360     $		0 )
361            END IF
362            IF (RORDER) THEN
363            CALL CCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
364     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
365     $                 NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
366     $		1 )
367            END IF
368            GO TO 190
369*
370  190       IF( FATAL.AND.SFATAL )
371     $         GO TO 210
372         END IF
373  200 CONTINUE
374      WRITE( NOUT, FMT = 9986 )
375      GO TO 230
376*
377  210 CONTINUE
378      WRITE( NOUT, FMT = 9985 )
379      GO TO 230
380*
381  220 CONTINUE
382      WRITE( NOUT, FMT = 9991 )
383*
384  230 CONTINUE
385      IF( TRACE )
386     $   CLOSE ( NTRA )
387      CLOSE ( NOUT )
388      STOP
389*
39010002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
39110001 FORMAT(' ROW-MAJOR DATA LAYOUT IS TESTED' )
39210000 FORMAT(' COLUMN-MAJOR DATA LAYOUT IS TESTED' )
393 9999 FORMAT(' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
394     $      'S THAN', F8.2 )
395 9998 FORMAT(' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 )
396 9997 FORMAT(' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
397     $      'THAN ', I2 )
398 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
399 9995 FORMAT(' TESTS OF THE COMPLEX          LEVEL 3 BLAS', //' THE F',
400     $      'OLLOWING PARAMETER VALUES WILL BE USED:' )
401 9994 FORMAT( '   FOR N              ', 9I6 )
402 9993 FORMAT( '   FOR ALPHA          ',
403     $      7( '(', F4.1, ',', F4.1, ')  ', : ) )
404 9992 FORMAT( '   FOR BETA           ',
405     $      7( '(', F4.1, ',', F4.1, ')  ', : ) )
406 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
407     $      /' ******* TESTS ABANDONED *******' )
408 9990 FORMAT(' SUBPROGRAM NAME ', A12,' NOT RECOGNIZED', /' ******* T',
409     $      'ESTS ABANDONED *******' )
410 9989 FORMAT(' ERROR IN CMMCH -  IN-LINE DOT PRODUCTS ARE BEING EVALU',
411     $      'ATED WRONGLY.', /' CMMCH WAS CALLED WITH TRANSA = ', A1,
412     $      'AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',
413     $    ' ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
414     $     'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
415     $      '*******' )
416 9988 FORMAT( A12,L2 )
417 9987 FORMAT( 1X, A12,' WAS NOT TESTED' )
418 9986 FORMAT( /' END OF TESTS' )
419 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
420 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
421*
422*     End of CBLAT3.
423*
424      END
425      SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
426     $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
427     $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G,
428     $                  IORDER )
429*
430*  Tests CGEMM.
431*
432*  Auxiliary routine for test program for Level 3 Blas.
433*
434*  -- Written on 8-February-1989.
435*     Jack Dongarra, Argonne National Laboratory.
436*     Iain Duff, AERE Harwell.
437*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
438*     Sven Hammarling, Numerical Algorithms Group Ltd.
439*
440*     .. Parameters ..
441      COMPLEX            ZERO
442      PARAMETER          ( ZERO = ( 0.0, 0.0 ) )
443      REAL               RZERO
444      PARAMETER          ( RZERO = 0.0 )
445*     .. Scalar Arguments ..
446      REAL               EPS, THRESH
447      INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
448      LOGICAL            FATAL, REWI, TRACE
449      CHARACTER*12       SNAME
450*     .. Array Arguments ..
451      COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
452     $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
453     $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
454     $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
455     $                   CS( NMAX*NMAX ), CT( NMAX )
456      REAL               G( NMAX )
457      INTEGER            IDIM( NIDIM )
458*     .. Local Scalars ..
459      COMPLEX            ALPHA, ALS, BETA, BLS
460      REAL               ERR, ERRMAX
461      INTEGER            I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
462     $                   LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
463     $                   MA, MB, MS, N, NA, NARGS, NB, NC, NS
464      LOGICAL            NULL, RESET, SAME, TRANA, TRANB
465      CHARACTER*1        TRANAS, TRANBS, TRANSA, TRANSB
466      CHARACTER*3        ICH
467*     .. Local Arrays ..
468      LOGICAL            ISAME( 13 )
469*     .. External Functions ..
470      LOGICAL            LCE, LCERES
471      EXTERNAL           LCE, LCERES
472*     .. External Subroutines ..
473      EXTERNAL           CCGEMM, CMAKE, CMMCH
474*     .. Intrinsic Functions ..
475      INTRINSIC          MAX
476*     .. Scalars in Common ..
477      INTEGER            INFOT, NOUTC
478      LOGICAL            LERR, OK
479*     .. Common blocks ..
480      COMMON             /INFOC/INFOT, NOUTC, OK, LERR
481*     .. Data statements ..
482      DATA               ICH/'NTC'/
483*     .. Executable Statements ..
484*
485      NARGS = 13
486      NC = 0
487      RESET = .TRUE.
488      ERRMAX = RZERO
489*
490      DO 110 IM = 1, NIDIM
491         M = IDIM( IM )
492*
493         DO 100 IN = 1, NIDIM
494            N = IDIM( IN )
495*           Set LDC to 1 more than minimum value if room.
496            LDC = M
497            IF( LDC.LT.NMAX )
498     $         LDC = LDC + 1
499*           Skip tests if not enough room.
500            IF( LDC.GT.NMAX )
501     $         GO TO 100
502            LCC = LDC*N
503            NULL = N.LE.0.OR.M.LE.0
504*
505            DO 90 IK = 1, NIDIM
506               K = IDIM( IK )
507*
508               DO 80 ICA = 1, 3
509                  TRANSA = ICH( ICA: ICA )
510                  TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
511*
512                  IF( TRANA )THEN
513                     MA = K
514                     NA = M
515                  ELSE
516                     MA = M
517                     NA = K
518                  END IF
519*                 Set LDA to 1 more than minimum value if room.
520                  LDA = MA
521                  IF( LDA.LT.NMAX )
522     $               LDA = LDA + 1
523*                 Skip tests if not enough room.
524                  IF( LDA.GT.NMAX )
525     $               GO TO 80
526                  LAA = LDA*NA
527*
528*                 Generate the matrix A.
529*
530                  CALL CMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
531     $                        RESET, ZERO )
532*
533                  DO 70 ICB = 1, 3
534                     TRANSB = ICH( ICB: ICB )
535                     TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
536*
537                     IF( TRANB )THEN
538                        MB = N
539                        NB = K
540                     ELSE
541                        MB = K
542                        NB = N
543                     END IF
544*                    Set LDB to 1 more than minimum value if room.
545                     LDB = MB
546                     IF( LDB.LT.NMAX )
547     $                  LDB = LDB + 1
548*                    Skip tests if not enough room.
549                     IF( LDB.GT.NMAX )
550     $                  GO TO 70
551                     LBB = LDB*NB
552*
553*                    Generate the matrix B.
554*
555                     CALL CMAKE( 'ge', ' ', ' ', MB, NB, B, NMAX, BB,
556     $                           LDB, RESET, ZERO )
557*
558                     DO 60 IA = 1, NALF
559                        ALPHA = ALF( IA )
560*
561                        DO 50 IB = 1, NBET
562                           BETA = BET( IB )
563*
564*                          Generate the matrix C.
565*
566                           CALL CMAKE( 'ge', ' ', ' ', M, N, C, NMAX,
567     $                                 CC, LDC, RESET, ZERO )
568*
569                           NC = NC + 1
570*
571*                          Save every datum before calling the
572*                          subroutine.
573*
574                           TRANAS = TRANSA
575                           TRANBS = TRANSB
576                           MS = M
577                           NS = N
578                           KS = K
579                           ALS = ALPHA
580                           DO 10 I = 1, LAA
581                              AS( I ) = AA( I )
582   10                      CONTINUE
583                           LDAS = LDA
584                           DO 20 I = 1, LBB
585                              BS( I ) = BB( I )
586   20                      CONTINUE
587                           LDBS = LDB
588                           BLS = BETA
589                           DO 30 I = 1, LCC
590                              CS( I ) = CC( I )
591   30                      CONTINUE
592                           LDCS = LDC
593*
594*                          Call the subroutine.
595*
596                           IF( TRACE )
597     $                        CALL CPRCN1(NTRA, NC, SNAME, IORDER,
598     $                        TRANSA, TRANSB, M, N, K, ALPHA, LDA,
599     $                        LDB, BETA, LDC)
600                           IF( REWI )
601     $                        REWIND NTRA
602                           CALL CCGEMM( IORDER, TRANSA, TRANSB, M, N,
603     $                                 K, ALPHA, AA, LDA, BB, LDB,
604     $                                 BETA, CC, LDC )
605*
606*                          Check if error-exit was taken incorrectly.
607*
608                           IF( .NOT.OK )THEN
609                              WRITE( NOUT, FMT = 9994 )
610                              FATAL = .TRUE.
611                              GO TO 120
612                           END IF
613*
614*                          See what data changed inside subroutines.
615*
616                           ISAME( 1 ) = TRANSA.EQ.TRANAS
617                           ISAME( 2 ) = TRANSB.EQ.TRANBS
618                           ISAME( 3 ) = MS.EQ.M
619                           ISAME( 4 ) = NS.EQ.N
620                           ISAME( 5 ) = KS.EQ.K
621                           ISAME( 6 ) = ALS.EQ.ALPHA
622                           ISAME( 7 ) = LCE( AS, AA, LAA )
623                           ISAME( 8 ) = LDAS.EQ.LDA
624                           ISAME( 9 ) = LCE( BS, BB, LBB )
625                           ISAME( 10 ) = LDBS.EQ.LDB
626                           ISAME( 11 ) = BLS.EQ.BETA
627                           IF( NULL )THEN
628                              ISAME( 12 ) = LCE( CS, CC, LCC )
629                           ELSE
630                             ISAME( 12 ) = LCERES( 'ge', ' ', M, N, CS,
631     $                                      CC, LDC )
632                           END IF
633                           ISAME( 13 ) = LDCS.EQ.LDC
634*
635*                          If data was incorrectly changed, report
636*                          and return.
637*
638                           SAME = .TRUE.
639                           DO 40 I = 1, NARGS
640                              SAME = SAME.AND.ISAME( I )
641                              IF( .NOT.ISAME( I ) )
642     $                           WRITE( NOUT, FMT = 9998 )I
643   40                      CONTINUE
644                           IF( .NOT.SAME )THEN
645                              FATAL = .TRUE.
646                              GO TO 120
647                           END IF
648*
649                           IF( .NOT.NULL )THEN
650*
651*                             Check the result.
652*
653                             CALL CMMCH( TRANSA, TRANSB, M, N, K,
654     $                                   ALPHA, A, NMAX, B, NMAX, BETA,
655     $                                   C, NMAX, CT, G, CC, LDC, EPS,
656     $                                   ERR, FATAL, NOUT, .TRUE. )
657                              ERRMAX = MAX( ERRMAX, ERR )
658*                             If got really bad answer, report and
659*                             return.
660                              IF( FATAL )
661     $                           GO TO 120
662                           END IF
663*
664   50                   CONTINUE
665*
666   60                CONTINUE
667*
668   70             CONTINUE
669*
670   80          CONTINUE
671*
672   90       CONTINUE
673*
674  100    CONTINUE
675*
676  110 CONTINUE
677*
678*     Report result.
679*
680      IF( ERRMAX.LT.THRESH )THEN
681         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
682         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
683      ELSE
684         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
685         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
686      END IF
687      GO TO 130
688*
689  120 CONTINUE
690      WRITE( NOUT, FMT = 9996 )SNAME
691      CALL CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB,
692     $           M, N, K, ALPHA, LDA, LDB, BETA, LDC)
693*
694  130 CONTINUE
695      RETURN
696*
69710003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR    COMPUTATIONAL ',
698     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
699     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
70010002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
701     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
702     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
70310001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR    COMPUTATIONAL TESTS',
704     $ ' (', I6, ' CALL', 'S)' )
70510000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
706     $ ' (', I6, ' CALL', 'S)' )
707 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
708     $      'ANGED INCORRECTLY *******' )
709 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
710 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',',
711     $     3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
712     $     ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
713 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
714     $      '******' )
715*
716*     End of CCHK1.
717*
718      END
719*
720      SUBROUTINE CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N,
721     $                 K, ALPHA, LDA, LDB, BETA, LDC)
722      INTEGER          NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC
723      COMPLEX          ALPHA, BETA
724      CHARACTER*1      TRANSA, TRANSB
725      CHARACTER*12     SNAME
726      CHARACTER*14     CRC, CTA,CTB
727
728      IF (TRANSA.EQ.'N')THEN
729         CTA = '  CblasNoTrans'
730      ELSE IF (TRANSA.EQ.'T')THEN
731         CTA = '    CblasTrans'
732      ELSE
733         CTA = 'CblasConjTrans'
734      END IF
735      IF (TRANSB.EQ.'N')THEN
736         CTB = '  CblasNoTrans'
737      ELSE IF (TRANSB.EQ.'T')THEN
738         CTB = '    CblasTrans'
739      ELSE
740         CTB = 'CblasConjTrans'
741      END IF
742      IF (IORDER.EQ.1)THEN
743         CRC = ' CblasRowMajor'
744      ELSE
745         CRC = ' CblasColMajor'
746      END IF
747      WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CTA,CTB
748      WRITE(NOUT, FMT = 9994)M, N, K, ALPHA, LDA, LDB, BETA, LDC
749
750 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
751 9994 FORMAT( 10X, 3( I3, ',' ) ,' (', F4.1,',',F4.1,') , A,',
752     $ I3, ', B,', I3, ', (', F4.1,',',F4.1,') , C,', I3, ').' )
753      END
754*
755      SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
756     $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
757     $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G,
758     $                  IORDER )
759*
760*  Tests CHEMM and CSYMM.
761*
762*  Auxiliary routine for test program for Level 3 Blas.
763*
764*  -- Written on 8-February-1989.
765*     Jack Dongarra, Argonne National Laboratory.
766*     Iain Duff, AERE Harwell.
767*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
768*     Sven Hammarling, Numerical Algorithms Group Ltd.
769*
770*     .. Parameters ..
771      COMPLEX            ZERO
772      PARAMETER          ( ZERO = ( 0.0, 0.0 ) )
773      REAL               RZERO
774      PARAMETER          ( RZERO = 0.0 )
775*     .. Scalar Arguments ..
776      REAL               EPS, THRESH
777      INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
778      LOGICAL            FATAL, REWI, TRACE
779      CHARACTER*12       SNAME
780*     .. Array Arguments ..
781      COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
782     $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
783     $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
784     $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
785     $                   CS( NMAX*NMAX ), CT( NMAX )
786      REAL               G( NMAX )
787      INTEGER            IDIM( NIDIM )
788*     .. Local Scalars ..
789      COMPLEX            ALPHA, ALS, BETA, BLS
790      REAL               ERR, ERRMAX
791      INTEGER            I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
792     $                   LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
793     $                   NARGS, NC, NS
794      LOGICAL            CONJ, LEFT, NULL, RESET, SAME
795      CHARACTER*1        SIDE, SIDES, UPLO, UPLOS
796      CHARACTER*2        ICHS, ICHU
797*     .. Local Arrays ..
798      LOGICAL            ISAME( 13 )
799*     .. External Functions ..
800      LOGICAL            LCE, LCERES
801      EXTERNAL           LCE, LCERES
802*     .. External Subroutines ..
803      EXTERNAL           CCHEMM, CMAKE, CMMCH, CCSYMM
804*     .. Intrinsic Functions ..
805      INTRINSIC          MAX
806*     .. Scalars in Common ..
807      INTEGER            INFOT, NOUTC
808      LOGICAL            LERR, OK
809*     .. Common blocks ..
810      COMMON             /INFOC/INFOT, NOUTC, OK, LERR
811*     .. Data statements ..
812      DATA               ICHS/'LR'/, ICHU/'UL'/
813*     .. Executable Statements ..
814      CONJ = SNAME( 8: 9 ).EQ.'he'
815*
816      NARGS = 12
817      NC = 0
818      RESET = .TRUE.
819      ERRMAX = RZERO
820*
821      DO 100 IM = 1, NIDIM
822         M = IDIM( IM )
823*
824         DO 90 IN = 1, NIDIM
825            N = IDIM( IN )
826*           Set LDC to 1 more than minimum value if room.
827            LDC = M
828            IF( LDC.LT.NMAX )
829     $         LDC = LDC + 1
830*           Skip tests if not enough room.
831            IF( LDC.GT.NMAX )
832     $         GO TO 90
833            LCC = LDC*N
834            NULL = N.LE.0.OR.M.LE.0
835*           Set LDB to 1 more than minimum value if room.
836            LDB = M
837            IF( LDB.LT.NMAX )
838     $         LDB = LDB + 1
839*           Skip tests if not enough room.
840            IF( LDB.GT.NMAX )
841     $         GO TO 90
842            LBB = LDB*N
843*
844*           Generate the matrix B.
845*
846            CALL CMAKE( 'ge', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET,
847     $                  ZERO )
848*
849            DO 80 ICS = 1, 2
850               SIDE = ICHS( ICS: ICS )
851               LEFT = SIDE.EQ.'L'
852*
853               IF( LEFT )THEN
854                  NA = M
855               ELSE
856                  NA = N
857               END IF
858*              Set LDA to 1 more than minimum value if room.
859               LDA = NA
860               IF( LDA.LT.NMAX )
861     $            LDA = LDA + 1
862*              Skip tests if not enough room.
863               IF( LDA.GT.NMAX )
864     $            GO TO 80
865               LAA = LDA*NA
866*
867               DO 70 ICU = 1, 2
868                  UPLO = ICHU( ICU: ICU )
869*
870*                 Generate the hermitian or symmetric matrix A.
871*
872                  CALL CMAKE(SNAME( 8: 9 ), UPLO, ' ', NA, NA, A, NMAX,
873     $                        AA, LDA, RESET, ZERO )
874*
875                  DO 60 IA = 1, NALF
876                     ALPHA = ALF( IA )
877*
878                     DO 50 IB = 1, NBET
879                        BETA = BET( IB )
880*
881*                       Generate the matrix C.
882*
883                        CALL CMAKE( 'ge', ' ', ' ', M, N, C, NMAX, CC,
884     $                              LDC, RESET, ZERO )
885*
886                        NC = NC + 1
887*
888*                       Save every datum before calling the
889*                       subroutine.
890*
891                        SIDES = SIDE
892                        UPLOS = UPLO
893                        MS = M
894                        NS = N
895                        ALS = ALPHA
896                        DO 10 I = 1, LAA
897                           AS( I ) = AA( I )
898   10                   CONTINUE
899                        LDAS = LDA
900                        DO 20 I = 1, LBB
901                           BS( I ) = BB( I )
902   20                   CONTINUE
903                        LDBS = LDB
904                        BLS = BETA
905                        DO 30 I = 1, LCC
906                           CS( I ) = CC( I )
907   30                   CONTINUE
908                        LDCS = LDC
909*
910*                       Call the subroutine.
911*
912                        IF( TRACE )
913     $                      CALL CPRCN2(NTRA, NC, SNAME, IORDER,
914     $                      SIDE, UPLO, M, N, ALPHA, LDA, LDB,
915     $                      BETA, LDC)
916                        IF( REWI )
917     $                     REWIND NTRA
918                        IF( CONJ )THEN
919                           CALL CCHEMM( IORDER, SIDE, UPLO, M, N,
920     $                                 ALPHA, AA, LDA, BB, LDB, BETA,
921     $                                 CC, LDC )
922                        ELSE
923                           CALL CCSYMM( IORDER, SIDE, UPLO, M, N,
924     $                                 ALPHA, AA, LDA, BB, LDB, BETA,
925     $                                 CC, LDC )
926                        END IF
927*
928*                       Check if error-exit was taken incorrectly.
929*
930                        IF( .NOT.OK )THEN
931                           WRITE( NOUT, FMT = 9994 )
932                           FATAL = .TRUE.
933                           GO TO 110
934                        END IF
935*
936*                       See what data changed inside subroutines.
937*
938                        ISAME( 1 ) = SIDES.EQ.SIDE
939                        ISAME( 2 ) = UPLOS.EQ.UPLO
940                        ISAME( 3 ) = MS.EQ.M
941                        ISAME( 4 ) = NS.EQ.N
942                        ISAME( 5 ) = ALS.EQ.ALPHA
943                        ISAME( 6 ) = LCE( AS, AA, LAA )
944                        ISAME( 7 ) = LDAS.EQ.LDA
945                        ISAME( 8 ) = LCE( BS, BB, LBB )
946                        ISAME( 9 ) = LDBS.EQ.LDB
947                        ISAME( 10 ) = BLS.EQ.BETA
948                        IF( NULL )THEN
949                           ISAME( 11 ) = LCE( CS, CC, LCC )
950                        ELSE
951                           ISAME( 11 ) = LCERES( 'ge', ' ', M, N, CS,
952     $                                   CC, LDC )
953                        END IF
954                        ISAME( 12 ) = LDCS.EQ.LDC
955*
956*                       If data was incorrectly changed, report and
957*                       return.
958*
959                        SAME = .TRUE.
960                        DO 40 I = 1, NARGS
961                           SAME = SAME.AND.ISAME( I )
962                           IF( .NOT.ISAME( I ) )
963     $                        WRITE( NOUT, FMT = 9998 )I
964   40                   CONTINUE
965                        IF( .NOT.SAME )THEN
966                           FATAL = .TRUE.
967                           GO TO 110
968                        END IF
969*
970                        IF( .NOT.NULL )THEN
971*
972*                          Check the result.
973*
974                           IF( LEFT )THEN
975                              CALL CMMCH( 'N', 'N', M, N, M, ALPHA, A,
976     $                                    NMAX, B, NMAX, BETA, C, NMAX,
977     $                                    CT, G, CC, LDC, EPS, ERR,
978     $                                    FATAL, NOUT, .TRUE. )
979                           ELSE
980                              CALL CMMCH( 'N', 'N', M, N, N, ALPHA, B,
981     $                                    NMAX, A, NMAX, BETA, C, NMAX,
982     $                                    CT, G, CC, LDC, EPS, ERR,
983     $                                    FATAL, NOUT, .TRUE. )
984                           END IF
985                           ERRMAX = MAX( ERRMAX, ERR )
986*                          If got really bad answer, report and
987*                          return.
988                           IF( FATAL )
989     $                        GO TO 110
990                        END IF
991*
992   50                CONTINUE
993*
994   60             CONTINUE
995*
996   70          CONTINUE
997*
998   80       CONTINUE
999*
1000   90    CONTINUE
1001*
1002  100 CONTINUE
1003*
1004*     Report result.
1005*
1006      IF( ERRMAX.LT.THRESH )THEN
1007         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1008         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1009      ELSE
1010         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1011         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1012      END IF
1013      GO TO 120
1014*
1015  110 CONTINUE
1016      WRITE( NOUT, FMT = 9996 )SNAME
1017      CALL CPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, ALPHA, LDA,
1018     $           LDB, BETA, LDC)
1019*
1020  120 CONTINUE
1021      RETURN
1022*
102310003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR    COMPUTATIONAL ',
1024     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1025     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
102610002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1027     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1028     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
102910001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR    COMPUTATIONAL TESTS',
1030     $ ' (', I6, ' CALL', 'S)' )
103110000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1032     $ ' (', I6, ' CALL', 'S)' )
1033 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1034     $      'ANGED INCORRECTLY *******' )
1035 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
1036 9995 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1037     $      '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
1038     $      ',', F4.1, '), C,', I3, ')    .' )
1039 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1040     $      '******' )
1041*
1042*     End of CCHK2.
1043*
1044      END
1045*
1046      SUBROUTINE CPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N,
1047     $                 ALPHA, LDA, LDB, BETA, LDC)
1048      INTEGER          NOUT, NC, IORDER, M, N, LDA, LDB, LDC
1049      COMPLEX          ALPHA, BETA
1050      CHARACTER*1      SIDE, UPLO
1051      CHARACTER*12     SNAME
1052      CHARACTER*14     CRC, CS,CU
1053
1054      IF (SIDE.EQ.'L')THEN
1055         CS =  '     CblasLeft'
1056      ELSE
1057         CS =  '    CblasRight'
1058      END IF
1059      IF (UPLO.EQ.'U')THEN
1060         CU =  '    CblasUpper'
1061      ELSE
1062         CU =  '    CblasLower'
1063      END IF
1064      IF (IORDER.EQ.1)THEN
1065         CRC = ' CblasRowMajor'
1066      ELSE
1067         CRC = ' CblasColMajor'
1068      END IF
1069      WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
1070      WRITE(NOUT, FMT = 9994)M, N, ALPHA, LDA, LDB, BETA, LDC
1071
1072 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
1073 9994 FORMAT( 10X, 2( I3, ',' ),' (',F4.1,',',F4.1, '), A,', I3,
1074     $ ', B,', I3, ', (',F4.1,',',F4.1, '), ', 'C,', I3, ').' )
1075      END
1076*
1077      SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1078     $                  FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS,
1079     $                  B, BB, BS, CT, G, C, IORDER )
1080*
1081*  Tests CTRMM and CTRSM.
1082*
1083*  Auxiliary routine for test program for Level 3 Blas.
1084*
1085*  -- Written on 8-February-1989.
1086*     Jack Dongarra, Argonne National Laboratory.
1087*     Iain Duff, AERE Harwell.
1088*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
1089*     Sven Hammarling, Numerical Algorithms Group Ltd.
1090*
1091*     .. Parameters ..
1092      COMPLEX            ZERO, ONE
1093      PARAMETER          ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
1094      REAL               RZERO
1095      PARAMETER          ( RZERO = 0.0 )
1096*     .. Scalar Arguments ..
1097      REAL               EPS, THRESH
1098      INTEGER            NALF, NIDIM, NMAX, NOUT, NTRA, IORDER
1099      LOGICAL            FATAL, REWI, TRACE
1100      CHARACTER*12       SNAME
1101*     .. Array Arguments ..
1102      COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1103     $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
1104     $                   BB( NMAX*NMAX ), BS( NMAX*NMAX ),
1105     $                   C( NMAX, NMAX ), CT( NMAX )
1106      REAL               G( NMAX )
1107      INTEGER            IDIM( NIDIM )
1108*     .. Local Scalars ..
1109      COMPLEX            ALPHA, ALS
1110      REAL               ERR, ERRMAX
1111      INTEGER           I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
1112     $                   LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
1113     $                   NS
1114      LOGICAL            LEFT, NULL, RESET, SAME
1115      CHARACTER*1       DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
1116     $                   UPLOS
1117      CHARACTER*2        ICHD, ICHS, ICHU
1118      CHARACTER*3        ICHT
1119*     .. Local Arrays ..
1120      LOGICAL            ISAME( 13 )
1121*     .. External Functions ..
1122      LOGICAL            LCE, LCERES
1123      EXTERNAL           LCE, LCERES
1124*     .. External Subroutines ..
1125      EXTERNAL           CMAKE, CMMCH, CCTRMM, CCTRSM
1126*     .. Intrinsic Functions ..
1127      INTRINSIC          MAX
1128*     .. Scalars in Common ..
1129      INTEGER            INFOT, NOUTC
1130      LOGICAL            LERR, OK
1131*     .. Common blocks ..
1132      COMMON             /INFOC/INFOT, NOUTC, OK, LERR
1133*     .. Data statements ..
1134      DATA              ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/
1135*     .. Executable Statements ..
1136*
1137      NARGS = 11
1138      NC = 0
1139      RESET = .TRUE.
1140      ERRMAX = RZERO
1141*     Set up zero matrix for CMMCH.
1142      DO 20 J = 1, NMAX
1143         DO 10 I = 1, NMAX
1144            C( I, J ) = ZERO
1145   10    CONTINUE
1146   20 CONTINUE
1147*
1148      DO 140 IM = 1, NIDIM
1149         M = IDIM( IM )
1150*
1151         DO 130 IN = 1, NIDIM
1152            N = IDIM( IN )
1153*           Set LDB to 1 more than minimum value if room.
1154            LDB = M
1155            IF( LDB.LT.NMAX )
1156     $         LDB = LDB + 1
1157*           Skip tests if not enough room.
1158            IF( LDB.GT.NMAX )
1159     $         GO TO 130
1160            LBB = LDB*N
1161            NULL = M.LE.0.OR.N.LE.0
1162*
1163            DO 120 ICS = 1, 2
1164               SIDE = ICHS( ICS: ICS )
1165               LEFT = SIDE.EQ.'L'
1166               IF( LEFT )THEN
1167                  NA = M
1168               ELSE
1169                  NA = N
1170               END IF
1171*              Set LDA to 1 more than minimum value if room.
1172               LDA = NA
1173               IF( LDA.LT.NMAX )
1174     $            LDA = LDA + 1
1175*              Skip tests if not enough room.
1176               IF( LDA.GT.NMAX )
1177     $            GO TO 130
1178               LAA = LDA*NA
1179*
1180               DO 110 ICU = 1, 2
1181                  UPLO = ICHU( ICU: ICU )
1182*
1183                  DO 100 ICT = 1, 3
1184                     TRANSA = ICHT( ICT: ICT )
1185*
1186                     DO 90 ICD = 1, 2
1187                        DIAG = ICHD( ICD: ICD )
1188*
1189                        DO 80 IA = 1, NALF
1190                           ALPHA = ALF( IA )
1191*
1192*                          Generate the matrix A.
1193*
1194                           CALL CMAKE( 'tr', UPLO, DIAG, NA, NA, A,
1195     $                                 NMAX, AA, LDA, RESET, ZERO )
1196*
1197*                          Generate the matrix B.
1198*
1199                           CALL CMAKE( 'ge', ' ', ' ', M, N, B, NMAX,
1200     $                                 BB, LDB, RESET, ZERO )
1201*
1202                           NC = NC + 1
1203*
1204*                          Save every datum before calling the
1205*                          subroutine.
1206*
1207                           SIDES = SIDE
1208                           UPLOS = UPLO
1209                           TRANAS = TRANSA
1210                           DIAGS = DIAG
1211                           MS = M
1212                           NS = N
1213                           ALS = ALPHA
1214                           DO 30 I = 1, LAA
1215                              AS( I ) = AA( I )
1216   30                      CONTINUE
1217                           LDAS = LDA
1218                           DO 40 I = 1, LBB
1219                              BS( I ) = BB( I )
1220   40                      CONTINUE
1221                           LDBS = LDB
1222*
1223*                          Call the subroutine.
1224*
1225                           IF( SNAME( 10: 11 ).EQ.'mm' )THEN
1226                              IF( TRACE )
1227     $                           CALL CPRCN3( NTRA, NC, SNAME, IORDER,
1228     $                           SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1229     $                           LDA, LDB)
1230                              IF( REWI )
1231     $                           REWIND NTRA
1232                              CALL CCTRMM(IORDER, SIDE, UPLO, TRANSA,
1233     $                                    DIAG, M, N, ALPHA, AA, LDA,
1234     $                                    BB, LDB )
1235                           ELSE IF( SNAME( 10: 11 ).EQ.'sm' )THEN
1236                              IF( TRACE )
1237     $                           CALL CPRCN3( NTRA, NC, SNAME, IORDER,
1238     $                           SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1239     $                           LDA, LDB)
1240                              IF( REWI )
1241     $                           REWIND NTRA
1242                              CALL CCTRSM(IORDER, SIDE, UPLO, TRANSA,
1243     $                                   DIAG, M, N, ALPHA, AA, LDA,
1244     $                                   BB, LDB )
1245                           END IF
1246*
1247*                          Check if error-exit was taken incorrectly.
1248*
1249                           IF( .NOT.OK )THEN
1250                              WRITE( NOUT, FMT = 9994 )
1251                              FATAL = .TRUE.
1252                              GO TO 150
1253                           END IF
1254*
1255*                          See what data changed inside subroutines.
1256*
1257                           ISAME( 1 ) = SIDES.EQ.SIDE
1258                           ISAME( 2 ) = UPLOS.EQ.UPLO
1259                           ISAME( 3 ) = TRANAS.EQ.TRANSA
1260                           ISAME( 4 ) = DIAGS.EQ.DIAG
1261                           ISAME( 5 ) = MS.EQ.M
1262                           ISAME( 6 ) = NS.EQ.N
1263                           ISAME( 7 ) = ALS.EQ.ALPHA
1264                           ISAME( 8 ) = LCE( AS, AA, LAA )
1265                           ISAME( 9 ) = LDAS.EQ.LDA
1266                           IF( NULL )THEN
1267                              ISAME( 10 ) = LCE( BS, BB, LBB )
1268                           ELSE
1269                             ISAME( 10 ) = LCERES( 'ge', ' ', M, N, BS,
1270     $                                      BB, LDB )
1271                           END IF
1272                           ISAME( 11 ) = LDBS.EQ.LDB
1273*
1274*                          If data was incorrectly changed, report and
1275*                          return.
1276*
1277                           SAME = .TRUE.
1278                           DO 50 I = 1, NARGS
1279                              SAME = SAME.AND.ISAME( I )
1280                              IF( .NOT.ISAME( I ) )
1281     $                           WRITE( NOUT, FMT = 9998 )I
1282   50                      CONTINUE
1283                           IF( .NOT.SAME )THEN
1284                              FATAL = .TRUE.
1285                              GO TO 150
1286                           END IF
1287*
1288                           IF( .NOT.NULL )THEN
1289                              IF( SNAME( 10: 11 ).EQ.'mm' )THEN
1290*
1291*                                Check the result.
1292*
1293                                 IF( LEFT )THEN
1294                                   CALL CMMCH( TRANSA, 'N', M, N, M,
1295     $                                         ALPHA, A, NMAX, B, NMAX,
1296     $                                          ZERO, C, NMAX, CT, G,
1297     $                                          BB, LDB, EPS, ERR,
1298     $                                          FATAL, NOUT, .TRUE. )
1299                                 ELSE
1300                                    CALL CMMCH( 'N', TRANSA, M, N, N,
1301     $                                         ALPHA, B, NMAX, A, NMAX,
1302     $                                          ZERO, C, NMAX, CT, G,
1303     $                                          BB, LDB, EPS, ERR,
1304     $                                          FATAL, NOUT, .TRUE. )
1305                                 END IF
1306                              ELSE IF( SNAME( 10: 11 ).EQ.'sm' )THEN
1307*
1308*                                Compute approximation to original
1309*                                matrix.
1310*
1311                                 DO 70 J = 1, N
1312                                    DO 60 I = 1, M
1313                                       C( I, J ) = BB( I + ( J - 1 )*
1314     $                                             LDB )
1315                                       BB( I + ( J - 1 )*LDB ) = ALPHA*
1316     $                                    B( I, J )
1317   60                               CONTINUE
1318   70                            CONTINUE
1319*
1320                                 IF( LEFT )THEN
1321                                    CALL CMMCH( TRANSA, 'N', M, N, M,
1322     $                                          ONE, A, NMAX, C, NMAX,
1323     $                                          ZERO, B, NMAX, CT, G,
1324     $                                          BB, LDB, EPS, ERR,
1325     $                                          FATAL, NOUT, .FALSE. )
1326                                 ELSE
1327                                    CALL CMMCH( 'N', TRANSA, M, N, N,
1328     $                                          ONE, C, NMAX, A, NMAX,
1329     $                                          ZERO, B, NMAX, CT, G,
1330     $                                          BB, LDB, EPS, ERR,
1331     $                                          FATAL, NOUT, .FALSE. )
1332                                 END IF
1333                              END IF
1334                              ERRMAX = MAX( ERRMAX, ERR )
1335*                             If got really bad answer, report and
1336*                             return.
1337                              IF( FATAL )
1338     $                           GO TO 150
1339                           END IF
1340*
1341   80                   CONTINUE
1342*
1343   90                CONTINUE
1344*
1345  100             CONTINUE
1346*
1347  110          CONTINUE
1348*
1349  120       CONTINUE
1350*
1351  130    CONTINUE
1352*
1353  140 CONTINUE
1354*
1355*     Report result.
1356*
1357      IF( ERRMAX.LT.THRESH )THEN
1358         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1359         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1360      ELSE
1361         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1362         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1363      END IF
1364      GO TO 160
1365*
1366  150 CONTINUE
1367      WRITE( NOUT, FMT = 9996 )SNAME
1368      CALL CPRCN3( NTRA, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG,
1369     $      M, N, ALPHA, LDA, LDB)
1370*
1371  160 CONTINUE
1372      RETURN
1373*
137410003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR    COMPUTATIONAL ',
1375     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1376     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
137710002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1378     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1379     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
138010001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR    COMPUTATIONAL TESTS',
1381     $ ' (', I6, ' CALL', 'S)' )
138210000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1383     $ ' (', I6, ' CALL', 'S)' )
1384 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1385     $      'ANGED INCORRECTLY *******' )
1386 9996 FORMAT(' ******* ', A12,' FAILED ON CALL NUMBER:' )
1387 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ),
1388     $     '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ')         ',
1389     $      '      .' )
1390 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1391     $      '******' )
1392*
1393*     End of CCHK3.
1394*
1395      END
1396*
1397      SUBROUTINE CPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA,
1398     $                 DIAG, M, N, ALPHA, LDA, LDB)
1399      INTEGER          NOUT, NC, IORDER, M, N, LDA, LDB
1400      COMPLEX          ALPHA
1401      CHARACTER*1      SIDE, UPLO, TRANSA, DIAG
1402      CHARACTER*12     SNAME
1403      CHARACTER*14     CRC, CS, CU, CA, CD
1404
1405      IF (SIDE.EQ.'L')THEN
1406         CS =  '     CblasLeft'
1407      ELSE
1408         CS =  '    CblasRight'
1409      END IF
1410      IF (UPLO.EQ.'U')THEN
1411         CU =  '    CblasUpper'
1412      ELSE
1413         CU =  '    CblasLower'
1414      END IF
1415      IF (TRANSA.EQ.'N')THEN
1416         CA =  '  CblasNoTrans'
1417      ELSE IF (TRANSA.EQ.'T')THEN
1418         CA =  '    CblasTrans'
1419      ELSE
1420         CA =  'CblasConjTrans'
1421      END IF
1422      IF (DIAG.EQ.'N')THEN
1423         CD =  '  CblasNonUnit'
1424      ELSE
1425         CD =  '     CblasUnit'
1426      END IF
1427      IF (IORDER.EQ.1)THEN
1428         CRC = ' CblasRowMajor'
1429      ELSE
1430         CRC = ' CblasColMajor'
1431      END IF
1432      WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
1433      WRITE(NOUT, FMT = 9994)CA, CD, M, N, ALPHA, LDA, LDB
1434
1435 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
1436 9994 FORMAT( 10X, 2( A14, ',') , 2( I3, ',' ), ' (', F4.1, ',',
1437     $    F4.1, '), A,', I3, ', B,', I3, ').' )
1438      END
1439*
1440      SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1441     $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1442     $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G,
1443     $                  IORDER )
1444*
1445*  Tests CHERK and CSYRK.
1446*
1447*  Auxiliary routine for test program for Level 3 Blas.
1448*
1449*  -- Written on 8-February-1989.
1450*     Jack Dongarra, Argonne National Laboratory.
1451*     Iain Duff, AERE Harwell.
1452*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
1453*     Sven Hammarling, Numerical Algorithms Group Ltd.
1454*
1455*     .. Parameters ..
1456      COMPLEX            ZERO
1457      PARAMETER          ( ZERO = ( 0.0, 0.0 ) )
1458      REAL               RONE, RZERO
1459      PARAMETER          ( RONE = 1.0, RZERO = 0.0 )
1460*     .. Scalar Arguments ..
1461      REAL               EPS, THRESH
1462      INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1463      LOGICAL            FATAL, REWI, TRACE
1464      CHARACTER*12       SNAME
1465*     .. Array Arguments ..
1466      COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1467     $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
1468     $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
1469     $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
1470     $                   CS( NMAX*NMAX ), CT( NMAX )
1471      REAL               G( NMAX )
1472      INTEGER            IDIM( NIDIM )
1473*     .. Local Scalars ..
1474      COMPLEX            ALPHA, ALS, BETA, BETS
1475      REAL               ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS
1476      INTEGER            I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1477     $                   LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1478     $                   NARGS, NC, NS
1479      LOGICAL            CONJ, NULL, RESET, SAME, TRAN, UPPER
1480      CHARACTER*1        TRANS, TRANSS, TRANST, UPLO, UPLOS
1481      CHARACTER*2        ICHT, ICHU
1482*     .. Local Arrays ..
1483      LOGICAL            ISAME( 13 )
1484*     .. External Functions ..
1485      LOGICAL            LCE, LCERES
1486      EXTERNAL           LCE, LCERES
1487*     .. External Subroutines ..
1488      EXTERNAL           CCHERK, CMAKE, CMMCH, CCSYRK
1489*     .. Intrinsic Functions ..
1490      INTRINSIC          CMPLX, MAX, REAL
1491*     .. Scalars in Common ..
1492      INTEGER            INFOT, NOUTC
1493      LOGICAL            LERR, OK
1494*     .. Common blocks ..
1495      COMMON             /INFOC/INFOT, NOUTC, OK, LERR
1496*     .. Data statements ..
1497      DATA               ICHT/'NC'/, ICHU/'UL'/
1498*     .. Executable Statements ..
1499      CONJ = SNAME( 8: 9 ).EQ.'he'
1500*
1501      NARGS = 10
1502      NC = 0
1503      RESET = .TRUE.
1504      ERRMAX = RZERO
1505*
1506      DO 100 IN = 1, NIDIM
1507         N = IDIM( IN )
1508*        Set LDC to 1 more than minimum value if room.
1509         LDC = N
1510         IF( LDC.LT.NMAX )
1511     $      LDC = LDC + 1
1512*        Skip tests if not enough room.
1513         IF( LDC.GT.NMAX )
1514     $      GO TO 100
1515         LCC = LDC*N
1516*
1517         DO 90 IK = 1, NIDIM
1518            K = IDIM( IK )
1519*
1520            DO 80 ICT = 1, 2
1521               TRANS = ICHT( ICT: ICT )
1522               TRAN = TRANS.EQ.'C'
1523               IF( TRAN.AND..NOT.CONJ )
1524     $            TRANS = 'T'
1525               IF( TRAN )THEN
1526                  MA = K
1527                  NA = N
1528               ELSE
1529                  MA = N
1530                  NA = K
1531               END IF
1532*              Set LDA to 1 more than minimum value if room.
1533               LDA = MA
1534               IF( LDA.LT.NMAX )
1535     $            LDA = LDA + 1
1536*              Skip tests if not enough room.
1537               IF( LDA.GT.NMAX )
1538     $            GO TO 80
1539               LAA = LDA*NA
1540*
1541*              Generate the matrix A.
1542*
1543               CALL CMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
1544     $                     RESET, ZERO )
1545*
1546               DO 70 ICU = 1, 2
1547                  UPLO = ICHU( ICU: ICU )
1548                  UPPER = UPLO.EQ.'U'
1549*
1550                  DO 60 IA = 1, NALF
1551                     ALPHA = ALF( IA )
1552                     IF( CONJ )THEN
1553                        RALPHA = REAL( ALPHA )
1554                        ALPHA = CMPLX( RALPHA, RZERO )
1555                     END IF
1556*
1557                     DO 50 IB = 1, NBET
1558                        BETA = BET( IB )
1559                        IF( CONJ )THEN
1560                           RBETA = REAL( BETA )
1561                           BETA = CMPLX( RBETA, RZERO )
1562                        END IF
1563                        NULL = N.LE.0
1564                        IF( CONJ )
1565     $                     NULL = NULL.OR.( ( K.LE.0.OR.RALPHA.EQ.
1566     $                            RZERO ).AND.RBETA.EQ.RONE )
1567*
1568*                       Generate the matrix C.
1569*
1570                        CALL CMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, C,
1571     $                              NMAX, CC, LDC, RESET, ZERO )
1572*
1573                        NC = NC + 1
1574*
1575*                       Save every datum before calling the subroutine.
1576*
1577                        UPLOS = UPLO
1578                        TRANSS = TRANS
1579                        NS = N
1580                        KS = K
1581                        IF( CONJ )THEN
1582                           RALS = RALPHA
1583                        ELSE
1584                           ALS = ALPHA
1585                        END IF
1586                        DO 10 I = 1, LAA
1587                           AS( I ) = AA( I )
1588   10                   CONTINUE
1589                        LDAS = LDA
1590                        IF( CONJ )THEN
1591                           RBETS = RBETA
1592                        ELSE
1593                           BETS = BETA
1594                        END IF
1595                        DO 20 I = 1, LCC
1596                           CS( I ) = CC( I )
1597   20                   CONTINUE
1598                        LDCS = LDC
1599*
1600*                       Call the subroutine.
1601*
1602                        IF( CONJ )THEN
1603                           IF( TRACE )
1604     $                        CALL CPRCN6( NTRA, NC, SNAME, IORDER,
1605     $                        UPLO, TRANS, N, K, RALPHA, LDA, RBETA,
1606     $                        LDC)
1607                           IF( REWI )
1608     $                        REWIND NTRA
1609                           CALL CCHERK( IORDER, UPLO, TRANS, N, K,
1610     $                                 RALPHA, AA, LDA, RBETA, CC,
1611     $                                 LDC )
1612                        ELSE
1613                           IF( TRACE )
1614     $                        CALL CPRCN4( NTRA, NC, SNAME, IORDER,
1615     $                        UPLO, TRANS, N, K, ALPHA, LDA, BETA, LDC)
1616                           IF( REWI )
1617     $                        REWIND NTRA
1618                           CALL CCSYRK( IORDER, UPLO, TRANS, N, K,
1619     $                                 ALPHA, AA, LDA, BETA, CC, LDC )
1620                        END IF
1621*
1622*                       Check if error-exit was taken incorrectly.
1623*
1624                        IF( .NOT.OK )THEN
1625                           WRITE( NOUT, FMT = 9992 )
1626                           FATAL = .TRUE.
1627                           GO TO 120
1628                        END IF
1629*
1630*                       See what data changed inside subroutines.
1631*
1632                        ISAME( 1 ) = UPLOS.EQ.UPLO
1633                        ISAME( 2 ) = TRANSS.EQ.TRANS
1634                        ISAME( 3 ) = NS.EQ.N
1635                        ISAME( 4 ) = KS.EQ.K
1636                        IF( CONJ )THEN
1637                           ISAME( 5 ) = RALS.EQ.RALPHA
1638                        ELSE
1639                           ISAME( 5 ) = ALS.EQ.ALPHA
1640                        END IF
1641                        ISAME( 6 ) = LCE( AS, AA, LAA )
1642                        ISAME( 7 ) = LDAS.EQ.LDA
1643                        IF( CONJ )THEN
1644                           ISAME( 8 ) = RBETS.EQ.RBETA
1645                        ELSE
1646                           ISAME( 8 ) = BETS.EQ.BETA
1647                        END IF
1648                        IF( NULL )THEN
1649                           ISAME( 9 ) = LCE( CS, CC, LCC )
1650                        ELSE
1651                           ISAME( 9 ) = LCERES( SNAME( 8: 9 ), UPLO, N,
1652     $                                  N, CS, CC, LDC )
1653                        END IF
1654                        ISAME( 10 ) = LDCS.EQ.LDC
1655*
1656*                       If data was incorrectly changed, report and
1657*                       return.
1658*
1659                        SAME = .TRUE.
1660                        DO 30 I = 1, NARGS
1661                           SAME = SAME.AND.ISAME( I )
1662                           IF( .NOT.ISAME( I ) )
1663     $                        WRITE( NOUT, FMT = 9998 )I
1664   30                   CONTINUE
1665                        IF( .NOT.SAME )THEN
1666                           FATAL = .TRUE.
1667                           GO TO 120
1668                        END IF
1669*
1670                        IF( .NOT.NULL )THEN
1671*
1672*                          Check the result column by column.
1673*
1674                           IF( CONJ )THEN
1675                              TRANST = 'C'
1676                           ELSE
1677                              TRANST = 'T'
1678                           END IF
1679                           JC = 1
1680                           DO 40 J = 1, N
1681                              IF( UPPER )THEN
1682                                 JJ = 1
1683                                 LJ = J
1684                              ELSE
1685                                 JJ = J
1686                                 LJ = N - J + 1
1687                              END IF
1688                              IF( TRAN )THEN
1689                                 CALL CMMCH( TRANST, 'N', LJ, 1, K,
1690     $                                       ALPHA, A( 1, JJ ), NMAX,
1691     $                                       A( 1, J ), NMAX, BETA,
1692     $                                       C( JJ, J ), NMAX, CT, G,
1693     $                                       CC( JC ), LDC, EPS, ERR,
1694     $                                       FATAL, NOUT, .TRUE. )
1695                              ELSE
1696                                 CALL CMMCH( 'N', TRANST, LJ, 1, K,
1697     $                                       ALPHA, A( JJ, 1 ), NMAX,
1698     $                                       A( J, 1 ), NMAX, BETA,
1699     $                                       C( JJ, J ), NMAX, CT, G,
1700     $                                       CC( JC ), LDC, EPS, ERR,
1701     $                                       FATAL, NOUT, .TRUE. )
1702                              END IF
1703                              IF( UPPER )THEN
1704                                 JC = JC + LDC
1705                              ELSE
1706                                 JC = JC + LDC + 1
1707                              END IF
1708                              ERRMAX = MAX( ERRMAX, ERR )
1709*                             If got really bad answer, report and
1710*                             return.
1711                              IF( FATAL )
1712     $                           GO TO 110
1713   40                      CONTINUE
1714                        END IF
1715*
1716   50                CONTINUE
1717*
1718   60             CONTINUE
1719*
1720   70          CONTINUE
1721*
1722   80       CONTINUE
1723*
1724   90    CONTINUE
1725*
1726  100 CONTINUE
1727*
1728*     Report result.
1729*
1730      IF( ERRMAX.LT.THRESH )THEN
1731         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
1732         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
1733      ELSE
1734         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
1735         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
1736      END IF
1737      GO TO 130
1738*
1739  110 CONTINUE
1740      IF( N.GT.1 )
1741     $   WRITE( NOUT, FMT = 9995 )J
1742*
1743  120 CONTINUE
1744      WRITE( NOUT, FMT = 9996 )SNAME
1745      IF( CONJ )THEN
1746      CALL CPRCN6( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, RALPHA,
1747     $   LDA, rBETA, LDC)
1748      ELSE
1749      CALL CPRCN4( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA,
1750     $   LDA, BETA, LDC)
1751      END IF
1752*
1753  130 CONTINUE
1754      RETURN
1755*
175610003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR    COMPUTATIONAL ',
1757     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1758     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
175910002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1760     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1761     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
176210001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR    COMPUTATIONAL TESTS',
1763     $ ' (', I6, ' CALL', 'S)' )
176410000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1765     $ ' (', I6, ' CALL', 'S)' )
1766 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1767     $      'ANGED INCORRECTLY *******' )
1768 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
1769 9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
1770 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1771     $     F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ')               ',
1772     $      '          .' )
1773 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1774     $      '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1,
1775     $      '), C,', I3, ')          .' )
1776 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1777     $      '******' )
1778*
1779*     End of CCHK4.
1780*
1781      END
1782*
1783      SUBROUTINE CPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
1784     $                 N, K, ALPHA, LDA, BETA, LDC)
1785      INTEGER          NOUT, NC, IORDER, N, K, LDA, LDC
1786      COMPLEX          ALPHA, BETA
1787      CHARACTER*1      UPLO, TRANSA
1788      CHARACTER*12     SNAME
1789      CHARACTER*14     CRC, CU, CA
1790
1791      IF (UPLO.EQ.'U')THEN
1792         CU =  '    CblasUpper'
1793      ELSE
1794         CU =  '    CblasLower'
1795      END IF
1796      IF (TRANSA.EQ.'N')THEN
1797         CA =  '  CblasNoTrans'
1798      ELSE IF (TRANSA.EQ.'T')THEN
1799         CA =  '    CblasTrans'
1800      ELSE
1801         CA =  'CblasConjTrans'
1802      END IF
1803      IF (IORDER.EQ.1)THEN
1804         CRC = ' CblasRowMajor'
1805      ELSE
1806         CRC = ' CblasColMajor'
1807      END IF
1808      WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
1809      WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC
1810
1811 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
1812 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1 ,'), A,',
1813     $        I3, ', (', F4.1,',', F4.1, '), C,', I3, ').' )
1814      END
1815*
1816*
1817      SUBROUTINE CPRCN6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
1818     $                 N, K, ALPHA, LDA, BETA, LDC)
1819      INTEGER          NOUT, NC, IORDER, N, K, LDA, LDC
1820      REAL             ALPHA, BETA
1821      CHARACTER*1      UPLO, TRANSA
1822      CHARACTER*12     SNAME
1823      CHARACTER*14     CRC, CU, CA
1824
1825      IF (UPLO.EQ.'U')THEN
1826         CU =  '    CblasUpper'
1827      ELSE
1828         CU =  '    CblasLower'
1829      END IF
1830      IF (TRANSA.EQ.'N')THEN
1831         CA =  '  CblasNoTrans'
1832      ELSE IF (TRANSA.EQ.'T')THEN
1833         CA =  '    CblasTrans'
1834      ELSE
1835         CA =  'CblasConjTrans'
1836      END IF
1837      IF (IORDER.EQ.1)THEN
1838         CRC = ' CblasRowMajor'
1839      ELSE
1840         CRC = ' CblasColMajor'
1841      END IF
1842      WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
1843      WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC
1844
1845 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
1846 9994 FORMAT( 10X, 2( I3, ',' ),
1847     $      F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' )
1848      END
1849*
1850      SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1851     $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1852     $                  AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
1853     $                  IORDER )
1854*
1855*  Tests CHER2K and CSYR2K.
1856*
1857*  Auxiliary routine for test program for Level 3 Blas.
1858*
1859*  -- Written on 8-February-1989.
1860*     Jack Dongarra, Argonne National Laboratory.
1861*     Iain Duff, AERE Harwell.
1862*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
1863*     Sven Hammarling, Numerical Algorithms Group Ltd.
1864*
1865*     .. Parameters ..
1866      COMPLEX            ZERO, ONE
1867      PARAMETER          ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
1868      REAL               RONE, RZERO
1869      PARAMETER          ( RONE = 1.0, RZERO = 0.0 )
1870*     .. Scalar Arguments ..
1871      REAL               EPS, THRESH
1872      INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1873      LOGICAL            FATAL, REWI, TRACE
1874      CHARACTER*12       SNAME
1875*     .. Array Arguments ..
1876      COMPLEX            AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1877     $                   ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1878     $                   BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1879     $                   CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1880     $                   W( 2*NMAX )
1881      REAL               G( NMAX )
1882      INTEGER            IDIM( NIDIM )
1883*     .. Local Scalars ..
1884      COMPLEX            ALPHA, ALS, BETA, BETS
1885      REAL               ERR, ERRMAX, RBETA, RBETS
1886      INTEGER            I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1887     $                   K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1888     $                   LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1889      LOGICAL            CONJ, NULL, RESET, SAME, TRAN, UPPER
1890      CHARACTER*1        TRANS, TRANSS, TRANST, UPLO, UPLOS
1891      CHARACTER*2        ICHT, ICHU
1892*     .. Local Arrays ..
1893      LOGICAL            ISAME( 13 )
1894*     .. External Functions ..
1895      LOGICAL            LCE, LCERES
1896      EXTERNAL           LCE, LCERES
1897*     .. External Subroutines ..
1898      EXTERNAL           CCHER2K, CMAKE, CMMCH, CCSYR2K
1899*     .. Intrinsic Functions ..
1900      INTRINSIC          CMPLX, CONJG, MAX, REAL
1901*     .. Scalars in Common ..
1902      INTEGER            INFOT, NOUTC
1903      LOGICAL            LERR, OK
1904*     .. Common blocks ..
1905      COMMON             /INFOC/INFOT, NOUTC, OK, LERR
1906*     .. Data statements ..
1907      DATA               ICHT/'NC'/, ICHU/'UL'/
1908*     .. Executable Statements ..
1909      CONJ = SNAME( 8: 9 ).EQ.'he'
1910*
1911      NARGS = 12
1912      NC = 0
1913      RESET = .TRUE.
1914      ERRMAX = RZERO
1915*
1916      DO 130 IN = 1, NIDIM
1917         N = IDIM( IN )
1918*        Set LDC to 1 more than minimum value if room.
1919         LDC = N
1920         IF( LDC.LT.NMAX )
1921     $      LDC = LDC + 1
1922*        Skip tests if not enough room.
1923         IF( LDC.GT.NMAX )
1924     $      GO TO 130
1925         LCC = LDC*N
1926*
1927         DO 120 IK = 1, NIDIM
1928            K = IDIM( IK )
1929*
1930            DO 110 ICT = 1, 2
1931               TRANS = ICHT( ICT: ICT )
1932               TRAN = TRANS.EQ.'C'
1933               IF( TRAN.AND..NOT.CONJ )
1934     $            TRANS = 'T'
1935               IF( TRAN )THEN
1936                  MA = K
1937                  NA = N
1938               ELSE
1939                  MA = N
1940                  NA = K
1941               END IF
1942*              Set LDA to 1 more than minimum value if room.
1943               LDA = MA
1944               IF( LDA.LT.NMAX )
1945     $            LDA = LDA + 1
1946*              Skip tests if not enough room.
1947               IF( LDA.GT.NMAX )
1948     $            GO TO 110
1949               LAA = LDA*NA
1950*
1951*              Generate the matrix A.
1952*
1953               IF( TRAN )THEN
1954                  CALL CMAKE( 'ge', ' ', ' ', MA, NA, AB, 2*NMAX, AA,
1955     $                        LDA, RESET, ZERO )
1956               ELSE
1957                 CALL CMAKE( 'ge', ' ', ' ', MA, NA, AB, NMAX, AA, LDA,
1958     $                        RESET, ZERO )
1959               END IF
1960*
1961*              Generate the matrix B.
1962*
1963               LDB = LDA
1964               LBB = LAA
1965               IF( TRAN )THEN
1966                  CALL CMAKE( 'ge', ' ', ' ', MA, NA, AB( K + 1 ),
1967     $                        2*NMAX, BB, LDB, RESET, ZERO )
1968               ELSE
1969                  CALL CMAKE( 'ge', ' ', ' ', MA, NA, AB( K*NMAX + 1 ),
1970     $                        NMAX, BB, LDB, RESET, ZERO )
1971               END IF
1972*
1973               DO 100 ICU = 1, 2
1974                  UPLO = ICHU( ICU: ICU )
1975                  UPPER = UPLO.EQ.'U'
1976*
1977                  DO 90 IA = 1, NALF
1978                     ALPHA = ALF( IA )
1979*
1980                     DO 80 IB = 1, NBET
1981                        BETA = BET( IB )
1982                        IF( CONJ )THEN
1983                           RBETA = REAL( BETA )
1984                           BETA = CMPLX( RBETA, RZERO )
1985                        END IF
1986                        NULL = N.LE.0
1987                        IF( CONJ )
1988     $                     NULL = NULL.OR.( ( K.LE.0.OR.ALPHA.EQ.
1989     $                            ZERO ).AND.RBETA.EQ.RONE )
1990*
1991*                       Generate the matrix C.
1992*
1993                        CALL CMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, C,
1994     $                              NMAX, CC, LDC, RESET, ZERO )
1995*
1996                        NC = NC + 1
1997*
1998*                       Save every datum before calling the subroutine.
1999*
2000                        UPLOS = UPLO
2001                        TRANSS = TRANS
2002                        NS = N
2003                        KS = K
2004                        ALS = ALPHA
2005                        DO 10 I = 1, LAA
2006                           AS( I ) = AA( I )
2007   10                   CONTINUE
2008                        LDAS = LDA
2009                        DO 20 I = 1, LBB
2010                           BS( I ) = BB( I )
2011   20                   CONTINUE
2012                        LDBS = LDB
2013                        IF( CONJ )THEN
2014                           RBETS = RBETA
2015                        ELSE
2016                           BETS = BETA
2017                        END IF
2018                        DO 30 I = 1, LCC
2019                           CS( I ) = CC( I )
2020   30                   CONTINUE
2021                        LDCS = LDC
2022*
2023*                       Call the subroutine.
2024*
2025                        IF( CONJ )THEN
2026                           IF( TRACE )
2027     $                        CALL CPRCN7( NTRA, NC, SNAME, IORDER,
2028     $                        UPLO, TRANS, N, K, ALPHA, LDA, LDB,
2029     $                        RBETA, LDC)
2030                           IF( REWI )
2031     $                        REWIND NTRA
2032                           CALL CCHER2K( IORDER, UPLO, TRANS, N, K,
2033     $                                  ALPHA, AA, LDA, BB, LDB, RBETA,
2034     $                                  CC, LDC )
2035                        ELSE
2036                           IF( TRACE )
2037     $                        CALL CPRCN5( NTRA, NC, SNAME, IORDER,
2038     $                        UPLO, TRANS, N, K, ALPHA, LDA, LDB,
2039     $                        BETA, LDC)
2040                           IF( REWI )
2041     $                        REWIND NTRA
2042                           CALL CCSYR2K( IORDER, UPLO, TRANS, N, K,
2043     $                                  ALPHA, AA, LDA, BB, LDB, BETA,
2044     $                                  CC, LDC )
2045                        END IF
2046*
2047*                       Check if error-exit was taken incorrectly.
2048*
2049                        IF( .NOT.OK )THEN
2050                           WRITE( NOUT, FMT = 9992 )
2051                           FATAL = .TRUE.
2052                           GO TO 150
2053                        END IF
2054*
2055*                       See what data changed inside subroutines.
2056*
2057                        ISAME( 1 ) = UPLOS.EQ.UPLO
2058                        ISAME( 2 ) = TRANSS.EQ.TRANS
2059                        ISAME( 3 ) = NS.EQ.N
2060                        ISAME( 4 ) = KS.EQ.K
2061                        ISAME( 5 ) = ALS.EQ.ALPHA
2062                        ISAME( 6 ) = LCE( AS, AA, LAA )
2063                        ISAME( 7 ) = LDAS.EQ.LDA
2064                        ISAME( 8 ) = LCE( BS, BB, LBB )
2065                        ISAME( 9 ) = LDBS.EQ.LDB
2066                        IF( CONJ )THEN
2067                           ISAME( 10 ) = RBETS.EQ.RBETA
2068                        ELSE
2069                           ISAME( 10 ) = BETS.EQ.BETA
2070                        END IF
2071                        IF( NULL )THEN
2072                           ISAME( 11 ) = LCE( CS, CC, LCC )
2073                        ELSE
2074                           ISAME( 11 ) = LCERES( 'he', UPLO, N, N, CS,
2075     $                                   CC, LDC )
2076                        END IF
2077                        ISAME( 12 ) = LDCS.EQ.LDC
2078*
2079*                       If data was incorrectly changed, report and
2080*                       return.
2081*
2082                        SAME = .TRUE.
2083                        DO 40 I = 1, NARGS
2084                           SAME = SAME.AND.ISAME( I )
2085                           IF( .NOT.ISAME( I ) )
2086     $                        WRITE( NOUT, FMT = 9998 )I
2087   40                   CONTINUE
2088                        IF( .NOT.SAME )THEN
2089                           FATAL = .TRUE.
2090                           GO TO 150
2091                        END IF
2092*
2093                        IF( .NOT.NULL )THEN
2094*
2095*                          Check the result column by column.
2096*
2097                           IF( CONJ )THEN
2098                              TRANST = 'C'
2099                           ELSE
2100                              TRANST = 'T'
2101                           END IF
2102                           JJAB = 1
2103                           JC = 1
2104                           DO 70 J = 1, N
2105                              IF( UPPER )THEN
2106                                 JJ = 1
2107                                 LJ = J
2108                              ELSE
2109                                 JJ = J
2110                                 LJ = N - J + 1
2111                              END IF
2112                              IF( TRAN )THEN
2113                                 DO 50 I = 1, K
2114                                    W( I ) = ALPHA*AB( ( J - 1 )*2*
2115     $                                       NMAX + K + I )
2116                                    IF( CONJ )THEN
2117                                       W( K + I ) = CONJG( ALPHA )*
2118     $                                              AB( ( J - 1 )*2*
2119     $                                              NMAX + I )
2120                                    ELSE
2121                                       W( K + I ) = ALPHA*
2122     $                                              AB( ( J - 1 )*2*
2123     $                                              NMAX + I )
2124                                    END IF
2125   50                            CONTINUE
2126                                 CALL CMMCH( TRANST, 'N', LJ, 1, 2*K,
2127     $                                      ONE, AB( JJAB ), 2*NMAX, W,
2128     $                                       2*NMAX, BETA, C( JJ, J ),
2129     $                                      NMAX, CT, G, CC( JC ), LDC,
2130     $                                       EPS, ERR, FATAL, NOUT,
2131     $                                       .TRUE. )
2132                              ELSE
2133                                 DO 60 I = 1, K
2134                                    IF( CONJ )THEN
2135                                       W( I ) = ALPHA*CONJG( AB( ( K +
2136     $                                          I - 1 )*NMAX + J ) )
2137                                       W( K + I ) = CONJG( ALPHA*
2138     $                                              AB( ( I - 1 )*NMAX +
2139     $                                              J ) )
2140                                    ELSE
2141                                       W( I ) = ALPHA*AB( ( K + I - 1 )*
2142     $                                          NMAX + J )
2143                                       W( K + I ) = ALPHA*
2144     $                                              AB( ( I - 1 )*NMAX +
2145     $                                              J )
2146                                    END IF
2147   60                            CONTINUE
2148                                 CALL CMMCH( 'N', 'N', LJ, 1, 2*K, ONE,
2149     $                                       AB( JJ ), NMAX, W, 2*NMAX,
2150     $                                      BETA, C( JJ, J ), NMAX, CT,
2151     $                                      G, CC( JC ), LDC, EPS, ERR,
2152     $                                       FATAL, NOUT, .TRUE. )
2153                              END IF
2154                              IF( UPPER )THEN
2155                                 JC = JC + LDC
2156                              ELSE
2157                                 JC = JC + LDC + 1
2158                                 IF( TRAN )
2159     $                              JJAB = JJAB + 2*NMAX
2160                              END IF
2161                              ERRMAX = MAX( ERRMAX, ERR )
2162*                             If got really bad answer, report and
2163*                             return.
2164                              IF( FATAL )
2165     $                           GO TO 140
2166   70                      CONTINUE
2167                        END IF
2168*
2169   80                CONTINUE
2170*
2171   90             CONTINUE
2172*
2173  100          CONTINUE
2174*
2175  110       CONTINUE
2176*
2177  120    CONTINUE
2178*
2179  130 CONTINUE
2180*
2181*     Report result.
2182*
2183      IF( ERRMAX.LT.THRESH )THEN
2184         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
2185         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
2186      ELSE
2187         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
2188         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
2189      END IF
2190      GO TO 160
2191*
2192  140 CONTINUE
2193      IF( N.GT.1 )
2194     $   WRITE( NOUT, FMT = 9995 )J
2195*
2196  150 CONTINUE
2197      WRITE( NOUT, FMT = 9996 )SNAME
2198      IF( CONJ )THEN
2199         CALL CPRCN7( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K,
2200     $      ALPHA, LDA, LDB, RBETA, LDC)
2201      ELSE
2202         CALL CPRCN5( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K,
2203     $      ALPHA, LDA, LDB, BETA, LDC)
2204      END IF
2205*
2206  160 CONTINUE
2207      RETURN
2208*
220910003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR    COMPUTATIONAL ',
2210     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2211     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
221210002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2213     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2214     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
221510001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR    COMPUTATIONAL TESTS',
2216     $ ' (', I6, ' CALL', 'S)' )
221710000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2218     $ ' (', I6, ' CALL', 'S)' )
2219 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
2220     $      'ANGED INCORRECTLY *******' )
2221 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
2222 9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
2223 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
2224     $      '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1,
2225     $      ', C,', I3, ')           .' )
2226 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
2227     $      '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
2228     $      ',', F4.1, '), C,', I3, ')    .' )
2229 9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2230     $      '******' )
2231*
2232*     End of CCHK5.
2233*
2234      END
2235*
2236      SUBROUTINE CPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
2237     $                 N, K, ALPHA, LDA, LDB, BETA, LDC)
2238      INTEGER          NOUT, NC, IORDER, N, K, LDA, LDB, LDC
2239      COMPLEX          ALPHA, BETA
2240      CHARACTER*1      UPLO, TRANSA
2241      CHARACTER*12     SNAME
2242      CHARACTER*14     CRC, CU, CA
2243
2244      IF (UPLO.EQ.'U')THEN
2245         CU =  '    CblasUpper'
2246      ELSE
2247         CU =  '    CblasLower'
2248      END IF
2249      IF (TRANSA.EQ.'N')THEN
2250         CA =  '  CblasNoTrans'
2251      ELSE IF (TRANSA.EQ.'T')THEN
2252         CA =  '    CblasTrans'
2253      ELSE
2254         CA =  'CblasConjTrans'
2255      END IF
2256      IF (IORDER.EQ.1)THEN
2257         CRC = ' CblasRowMajor'
2258      ELSE
2259         CRC = ' CblasColMajor'
2260      END IF
2261      WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
2262      WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
2263
2264 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
2265 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), A,',
2266     $  I3, ', B', I3, ', (', F4.1, ',', F4.1, '), C,', I3, ').' )
2267      END
2268*
2269*
2270      SUBROUTINE CPRCN7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
2271     $                 N, K, ALPHA, LDA, LDB, BETA, LDC)
2272      INTEGER          NOUT, NC, IORDER, N, K, LDA, LDB, LDC
2273      COMPLEX          ALPHA
2274      REAL             BETA
2275      CHARACTER*1      UPLO, TRANSA
2276      CHARACTER*12     SNAME
2277      CHARACTER*14     CRC, CU, CA
2278
2279      IF (UPLO.EQ.'U')THEN
2280         CU =  '    CblasUpper'
2281      ELSE
2282         CU =  '    CblasLower'
2283      END IF
2284      IF (TRANSA.EQ.'N')THEN
2285         CA =  '  CblasNoTrans'
2286      ELSE IF (TRANSA.EQ.'T')THEN
2287         CA =  '    CblasTrans'
2288      ELSE
2289         CA =  'CblasConjTrans'
2290      END IF
2291      IF (IORDER.EQ.1)THEN
2292         CRC = ' CblasRowMajor'
2293      ELSE
2294         CRC = ' CblasColMajor'
2295      END IF
2296      WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
2297      WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
2298
2299 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
2300 9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), A,',
2301     $      I3, ', B', I3, ',', F4.1, ', C,', I3, ').' )
2302      END
2303*
2304      SUBROUTINE CMAKE(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
2305     $                  TRANSL )
2306*
2307*  Generates values for an M by N matrix A.
2308*  Stores the values in the array AA in the data structure required
2309*  by the routine, with unwanted elements set to rogue value.
2310*
2311*  TYPE is 'ge', 'he', 'sy' or 'tr'.
2312*
2313*  Auxiliary routine for test program for Level 3 Blas.
2314*
2315*  -- Written on 8-February-1989.
2316*     Jack Dongarra, Argonne National Laboratory.
2317*     Iain Duff, AERE Harwell.
2318*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
2319*     Sven Hammarling, Numerical Algorithms Group Ltd.
2320*
2321*     .. Parameters ..
2322      COMPLEX            ZERO, ONE
2323      PARAMETER          ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
2324      COMPLEX            ROGUE
2325      PARAMETER          ( ROGUE = ( -1.0E10, 1.0E10 ) )
2326      REAL               RZERO
2327      PARAMETER          ( RZERO = 0.0 )
2328      REAL               RROGUE
2329      PARAMETER          ( RROGUE = -1.0E10 )
2330*     .. Scalar Arguments ..
2331      COMPLEX            TRANSL
2332      INTEGER            LDA, M, N, NMAX
2333      LOGICAL            RESET
2334      CHARACTER*1        DIAG, UPLO
2335      CHARACTER*2        TYPE
2336*     .. Array Arguments ..
2337      COMPLEX            A( NMAX, * ), AA( * )
2338*     .. Local Scalars ..
2339      INTEGER            I, IBEG, IEND, J, JJ
2340      LOGICAL            GEN, HER, LOWER, SYM, TRI, UNIT, UPPER
2341*     .. External Functions ..
2342      COMPLEX            CBEG
2343      EXTERNAL           CBEG
2344*     .. Intrinsic Functions ..
2345      INTRINSIC          CMPLX, CONJG, REAL
2346*     .. Executable Statements ..
2347      GEN = TYPE.EQ.'ge'
2348      HER = TYPE.EQ.'he'
2349      SYM = TYPE.EQ.'sy'
2350      TRI = TYPE.EQ.'tr'
2351      UPPER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'U'
2352      LOWER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'L'
2353      UNIT = TRI.AND.DIAG.EQ.'U'
2354*
2355*     Generate data in array A.
2356*
2357      DO 20 J = 1, N
2358         DO 10 I = 1, M
2359            IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
2360     $          THEN
2361               A( I, J ) = CBEG( RESET ) + TRANSL
2362               IF( I.NE.J )THEN
2363*                 Set some elements to zero
2364                  IF( N.GT.3.AND.J.EQ.N/2 )
2365     $               A( I, J ) = ZERO
2366                  IF( HER )THEN
2367                     A( J, I ) = CONJG( A( I, J ) )
2368                  ELSE IF( SYM )THEN
2369                     A( J, I ) = A( I, J )
2370                  ELSE IF( TRI )THEN
2371                     A( J, I ) = ZERO
2372                  END IF
2373               END IF
2374            END IF
2375   10    CONTINUE
2376         IF( HER )
2377     $      A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO )
2378         IF( TRI )
2379     $      A( J, J ) = A( J, J ) + ONE
2380         IF( UNIT )
2381     $      A( J, J ) = ONE
2382   20 CONTINUE
2383*
2384*     Store elements in array AS in data structure required by routine.
2385*
2386      IF( TYPE.EQ.'ge' )THEN
2387         DO 50 J = 1, N
2388            DO 30 I = 1, M
2389               AA( I + ( J - 1 )*LDA ) = A( I, J )
2390   30       CONTINUE
2391            DO 40 I = M + 1, LDA
2392               AA( I + ( J - 1 )*LDA ) = ROGUE
2393   40       CONTINUE
2394   50    CONTINUE
2395      ELSE IF( TYPE.EQ.'he'.OR.TYPE.EQ.'sy'.OR.TYPE.EQ.'tr' )THEN
2396         DO 90 J = 1, N
2397            IF( UPPER )THEN
2398               IBEG = 1
2399               IF( UNIT )THEN
2400                  IEND = J - 1
2401               ELSE
2402                  IEND = J
2403               END IF
2404            ELSE
2405               IF( UNIT )THEN
2406                  IBEG = J + 1
2407               ELSE
2408                  IBEG = J
2409               END IF
2410               IEND = N
2411            END IF
2412            DO 60 I = 1, IBEG - 1
2413               AA( I + ( J - 1 )*LDA ) = ROGUE
2414   60       CONTINUE
2415            DO 70 I = IBEG, IEND
2416               AA( I + ( J - 1 )*LDA ) = A( I, J )
2417   70       CONTINUE
2418            DO 80 I = IEND + 1, LDA
2419               AA( I + ( J - 1 )*LDA ) = ROGUE
2420   80       CONTINUE
2421            IF( HER )THEN
2422               JJ = J + ( J - 1 )*LDA
2423               AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE )
2424            END IF
2425   90    CONTINUE
2426      END IF
2427      RETURN
2428*
2429*     End of CMAKE.
2430*
2431      END
2432      SUBROUTINE CMMCH(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
2433     $                  BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
2434     $                  NOUT, MV )
2435*
2436*  Checks the results of the computational tests.
2437*
2438*  Auxiliary routine for test program for Level 3 Blas.
2439*
2440*  -- Written on 8-February-1989.
2441*     Jack Dongarra, Argonne National Laboratory.
2442*     Iain Duff, AERE Harwell.
2443*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
2444*     Sven Hammarling, Numerical Algorithms Group Ltd.
2445*
2446*     .. Parameters ..
2447      COMPLEX            ZERO
2448      PARAMETER          ( ZERO = ( 0.0, 0.0 ) )
2449      REAL               RZERO, RONE
2450      PARAMETER          ( RZERO = 0.0, RONE = 1.0 )
2451*     .. Scalar Arguments ..
2452      COMPLEX            ALPHA, BETA
2453      REAL               EPS, ERR
2454      INTEGER            KK, LDA, LDB, LDC, LDCC, M, N, NOUT
2455      LOGICAL            FATAL, MV
2456      CHARACTER*1        TRANSA, TRANSB
2457*     .. Array Arguments ..
2458      COMPLEX            A( LDA, * ), B( LDB, * ), C( LDC, * ),
2459     $                   CC( LDCC, * ), CT( * )
2460      REAL               G( * )
2461*     .. Local Scalars ..
2462      COMPLEX            CL
2463      REAL               ERRI
2464      INTEGER            I, J, K
2465      LOGICAL            CTRANA, CTRANB, TRANA, TRANB
2466*     .. Intrinsic Functions ..
2467      INTRINSIC          ABS, AIMAG, CONJG, MAX, REAL, SQRT
2468*     .. Statement Functions ..
2469      REAL               ABS1
2470*     .. Statement Function definitions ..
2471      ABS1( CL ) = ABS( REAL( CL ) ) + ABS( AIMAG( CL ) )
2472*     .. Executable Statements ..
2473      TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
2474      TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
2475      CTRANA = TRANSA.EQ.'C'
2476      CTRANB = TRANSB.EQ.'C'
2477*
2478*     Compute expected result, one column at a time, in CT using data
2479*     in A, B and C.
2480*     Compute gauges in G.
2481*
2482      DO 220 J = 1, N
2483*
2484         DO 10 I = 1, M
2485            CT( I ) = ZERO
2486            G( I ) = RZERO
2487   10    CONTINUE
2488         IF( .NOT.TRANA.AND..NOT.TRANB )THEN
2489            DO 30 K = 1, KK
2490               DO 20 I = 1, M
2491                  CT( I ) = CT( I ) + A( I, K )*B( K, J )
2492                  G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) )
2493   20          CONTINUE
2494   30       CONTINUE
2495         ELSE IF( TRANA.AND..NOT.TRANB )THEN
2496            IF( CTRANA )THEN
2497               DO 50 K = 1, KK
2498                  DO 40 I = 1, M
2499                     CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( K, J )
2500                     G( I ) = G( I ) + ABS1( A( K, I ) )*
2501     $                        ABS1( B( K, J ) )
2502   40             CONTINUE
2503   50          CONTINUE
2504            ELSE
2505               DO 70 K = 1, KK
2506                  DO 60 I = 1, M
2507                     CT( I ) = CT( I ) + A( K, I )*B( K, J )
2508                     G( I ) = G( I ) + ABS1( A( K, I ) )*
2509     $                        ABS1( B( K, J ) )
2510   60             CONTINUE
2511   70          CONTINUE
2512            END IF
2513         ELSE IF( .NOT.TRANA.AND.TRANB )THEN
2514            IF( CTRANB )THEN
2515               DO 90 K = 1, KK
2516                  DO 80 I = 1, M
2517                     CT( I ) = CT( I ) + A( I, K )*CONJG( B( J, K ) )
2518                     G( I ) = G( I ) + ABS1( A( I, K ) )*
2519     $                        ABS1( B( J, K ) )
2520   80             CONTINUE
2521   90          CONTINUE
2522            ELSE
2523               DO 110 K = 1, KK
2524                  DO 100 I = 1, M
2525                     CT( I ) = CT( I ) + A( I, K )*B( J, K )
2526                     G( I ) = G( I ) + ABS1( A( I, K ) )*
2527     $                        ABS1( B( J, K ) )
2528  100             CONTINUE
2529  110          CONTINUE
2530            END IF
2531         ELSE IF( TRANA.AND.TRANB )THEN
2532            IF( CTRANA )THEN
2533               IF( CTRANB )THEN
2534                  DO 130 K = 1, KK
2535                     DO 120 I = 1, M
2536                        CT( I ) = CT( I ) + CONJG( A( K, I ) )*
2537     $                            CONJG( B( J, K ) )
2538                        G( I ) = G( I ) + ABS1( A( K, I ) )*
2539     $                           ABS1( B( J, K ) )
2540  120                CONTINUE
2541  130             CONTINUE
2542               ELSE
2543                  DO 150 K = 1, KK
2544                     DO 140 I = 1, M
2545                       CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( J, K )
2546                       G( I ) = G( I ) + ABS1( A( K, I ) )*
2547     $                           ABS1( B( J, K ) )
2548  140                CONTINUE
2549  150             CONTINUE
2550               END IF
2551            ELSE
2552               IF( CTRANB )THEN
2553                  DO 170 K = 1, KK
2554                     DO 160 I = 1, M
2555                       CT( I ) = CT( I ) + A( K, I )*CONJG( B( J, K ) )
2556                       G( I ) = G( I ) + ABS1( A( K, I ) )*
2557     $                           ABS1( B( J, K ) )
2558  160                CONTINUE
2559  170             CONTINUE
2560               ELSE
2561                  DO 190 K = 1, KK
2562                     DO 180 I = 1, M
2563                        CT( I ) = CT( I ) + A( K, I )*B( J, K )
2564                        G( I ) = G( I ) + ABS1( A( K, I ) )*
2565     $                           ABS1( B( J, K ) )
2566  180                CONTINUE
2567  190             CONTINUE
2568               END IF
2569            END IF
2570         END IF
2571         DO 200 I = 1, M
2572            CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
2573            G( I ) = ABS1( ALPHA )*G( I ) +
2574     $               ABS1( BETA )*ABS1( C( I, J ) )
2575  200    CONTINUE
2576*
2577*        Compute the error ratio for this result.
2578*
2579         ERR = ZERO
2580         DO 210 I = 1, M
2581            ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS
2582            IF( G( I ).NE.RZERO )
2583     $         ERRI = ERRI/G( I )
2584            ERR = MAX( ERR, ERRI )
2585            IF( ERR*SQRT( EPS ).GE.RONE )
2586     $         GO TO 230
2587  210    CONTINUE
2588*
2589  220 CONTINUE
2590*
2591*     If the loop completes, all results are at least half accurate.
2592      GO TO 250
2593*
2594*     Report fatal error.
2595*
2596  230 FATAL = .TRUE.
2597      WRITE( NOUT, FMT = 9999 )
2598      DO 240 I = 1, M
2599         IF( MV )THEN
2600            WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
2601         ELSE
2602            WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
2603         END IF
2604  240 CONTINUE
2605      IF( N.GT.1 )
2606     $   WRITE( NOUT, FMT = 9997 )J
2607*
2608  250 CONTINUE
2609      RETURN
2610*
2611 9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2612     $     'F ACCURATE *******', /'                       EXPECTED RE',
2613     $     'SULT                    COMPUTED RESULT' )
2614 9998 FORMAT( 1X, I7, 2( '  (', G15.6, ',', G15.6, ')' ) )
2615 9997 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
2616*
2617*     End of CMMCH.
2618*
2619      END
2620      LOGICAL FUNCTION LCE( RI, RJ, LR )
2621*
2622*  Tests if two arrays are identical.
2623*
2624*  Auxiliary routine for test program for Level 3 Blas.
2625*
2626*  -- Written on 8-February-1989.
2627*     Jack Dongarra, Argonne National Laboratory.
2628*     Iain Duff, AERE Harwell.
2629*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
2630*     Sven Hammarling, Numerical Algorithms Group Ltd.
2631*
2632*     .. Scalar Arguments ..
2633      INTEGER            LR
2634*     .. Array Arguments ..
2635      COMPLEX            RI( * ), RJ( * )
2636*     .. Local Scalars ..
2637      INTEGER            I
2638*     .. Executable Statements ..
2639      DO 10 I = 1, LR
2640         IF( RI( I ).NE.RJ( I ) )
2641     $      GO TO 20
2642   10 CONTINUE
2643      LCE = .TRUE.
2644      GO TO 30
2645   20 CONTINUE
2646      LCE = .FALSE.
2647   30 RETURN
2648*
2649*     End of LCE.
2650*
2651      END
2652      LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA )
2653*
2654*  Tests if selected elements in two arrays are equal.
2655*
2656*  TYPE is 'ge' or 'he' or 'sy'.
2657*
2658*  Auxiliary routine for test program for Level 3 Blas.
2659*
2660*  -- Written on 8-February-1989.
2661*     Jack Dongarra, Argonne National Laboratory.
2662*     Iain Duff, AERE Harwell.
2663*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
2664*     Sven Hammarling, Numerical Algorithms Group Ltd.
2665*
2666*     .. Scalar Arguments ..
2667      INTEGER            LDA, M, N
2668      CHARACTER*1        UPLO
2669      CHARACTER*2        TYPE
2670*     .. Array Arguments ..
2671      COMPLEX            AA( LDA, * ), AS( LDA, * )
2672*     .. Local Scalars ..
2673      INTEGER            I, IBEG, IEND, J
2674      LOGICAL            UPPER
2675*     .. Executable Statements ..
2676      UPPER = UPLO.EQ.'U'
2677      IF( TYPE.EQ.'ge' )THEN
2678         DO 20 J = 1, N
2679            DO 10 I = M + 1, LDA
2680               IF( AA( I, J ).NE.AS( I, J ) )
2681     $            GO TO 70
2682   10       CONTINUE
2683   20    CONTINUE
2684      ELSE IF( TYPE.EQ.'he'.OR.TYPE.EQ.'sy' )THEN
2685         DO 50 J = 1, N
2686            IF( UPPER )THEN
2687               IBEG = 1
2688               IEND = J
2689            ELSE
2690               IBEG = J
2691               IEND = N
2692            END IF
2693            DO 30 I = 1, IBEG - 1
2694               IF( AA( I, J ).NE.AS( I, J ) )
2695     $            GO TO 70
2696   30       CONTINUE
2697            DO 40 I = IEND + 1, LDA
2698               IF( AA( I, J ).NE.AS( I, J ) )
2699     $            GO TO 70
2700   40       CONTINUE
2701   50    CONTINUE
2702      END IF
2703*
2704   60 CONTINUE
2705      LCERES = .TRUE.
2706      GO TO 80
2707   70 CONTINUE
2708      LCERES = .FALSE.
2709   80 RETURN
2710*
2711*     End of LCERES.
2712*
2713      END
2714      COMPLEX FUNCTION CBEG( RESET )
2715*
2716*  Generates complex numbers as pairs of random numbers uniformly
2717*  distributed between -0.5 and 0.5.
2718*
2719*  Auxiliary routine for test program for Level 3 Blas.
2720*
2721*  -- Written on 8-February-1989.
2722*     Jack Dongarra, Argonne National Laboratory.
2723*     Iain Duff, AERE Harwell.
2724*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
2725*     Sven Hammarling, Numerical Algorithms Group Ltd.
2726*
2727*     .. Scalar Arguments ..
2728      LOGICAL            RESET
2729*     .. Local Scalars ..
2730      INTEGER            I, IC, J, MI, MJ
2731*     .. Save statement ..
2732      SAVE               I, IC, J, MI, MJ
2733*     .. Intrinsic Functions ..
2734      INTRINSIC          CMPLX
2735*     .. Executable Statements ..
2736      IF( RESET )THEN
2737*        Initialize local variables.
2738         MI = 891
2739         MJ = 457
2740         I = 7
2741         J = 7
2742         IC = 0
2743         RESET = .FALSE.
2744      END IF
2745*
2746*     The sequence of values of I or J is bounded between 1 and 999.
2747*     If initial I or J = 1,2,3,6,7 or 9, the period will be 50.
2748*     If initial I or J = 4 or 8, the period will be 25.
2749*     If initial I or J = 5, the period will be 10.
2750*     IC is used to break up the period by skipping 1 value of I or J
2751*     in 6.
2752*
2753      IC = IC + 1
2754   10 I = I*MI
2755      J = J*MJ
2756      I = I - 1000*( I/1000 )
2757      J = J - 1000*( J/1000 )
2758      IF( IC.GE.5 )THEN
2759         IC = 0
2760         GO TO 10
2761      END IF
2762      CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 )
2763      RETURN
2764*
2765*     End of CBEG.
2766*
2767      END
2768      REAL FUNCTION SDIFF( X, Y )
2769*
2770*  Auxiliary routine for test program for Level 3 Blas.
2771*
2772*  -- Written on 8-February-1989.
2773*     Jack Dongarra, Argonne National Laboratory.
2774*     Iain Duff, AERE Harwell.
2775*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
2776*     Sven Hammarling, Numerical Algorithms Group Ltd.
2777*
2778*     .. Scalar Arguments ..
2779      REAL               X, Y
2780*     .. Executable Statements ..
2781      SDIFF = X - Y
2782      RETURN
2783*
2784*     End of SDIFF.
2785*
2786      END
2787