PROGRAM CBLAT3

*

*  Test program for the COMPLEX          Level 3 Blas.

*

*  The program must be driven by a short data file. The first 13 records

*  of the file are read using list-directed input, the last 9 records

*  are read using the format ( A12, L2 ). An annotated example of a data

*  file can be obtained by deleting the first 3 characters from the

*  following 22 lines:

*  'CBLAT3.SNAP'     NAME OF SNAPSHOT OUTPUT FILE

*  -1                UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)

*  F        LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.

*  F        LOGICAL FLAG, T TO STOP ON FAILURES.

*  T        LOGICAL FLAG, T TO TEST ERROR EXITS.

*  2        0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH

*  16.0     THRESHOLD VALUE OF TEST RATIO

*  6                 NUMBER OF VALUES OF N

*  0 1 2 3 5 9       VALUES OF N

*  3                 NUMBER OF VALUES OF ALPHA

*  (0.0,0.0) (1.0,0.0) (0.7,-0.9)       VALUES OF ALPHA

*  3                 NUMBER OF VALUES OF BETA

*  (0.0,0.0) (1.0,0.0) (1.3,-1.1)       VALUES OF BETA

*  cblas_cgemm  T PUT F FOR NO TEST. SAME COLUMNS.

*  cblas_chemm  T PUT F FOR NO TEST. SAME COLUMNS.

*  cblas_csymm  T PUT F FOR NO TEST. SAME COLUMNS.

*  cblas_ctrmm  T PUT F FOR NO TEST. SAME COLUMNS.

*  cblas_ctrsm  T PUT F FOR NO TEST. SAME COLUMNS.

*  cblas_cherk  T PUT F FOR NO TEST. SAME COLUMNS.

*  cblas_csyrk  T PUT F FOR NO TEST. SAME COLUMNS.

*  cblas_cher2k T PUT F FOR NO TEST. SAME COLUMNS.

*  cblas_csyr2k T PUT F FOR NO TEST. SAME COLUMNS.

*

*  See:

*

*     Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.

*     A Set of Level 3 Basic Linear Algebra Subprograms.

*

*     Technical Memorandum No.88 (Revision 1), Mathematics and

*     Computer Science Division, Argonne National Laboratory, 9700

*     South Cass Avenue, Argonne, Illinois 60439, US.

*

*  -- Written on 8-February-1989.

*     Jack Dongarra, Argonne National Laboratory.

*     Iain Duff, AERE Harwell.

*     Jeremy Du Croz, Numerical Algorithms Group Ltd.

*     Sven Hammarling, Numerical Algorithms Group Ltd.

*

*     .. Parameters ..

      INTEGER            NIN, NOUT

      PARAMETER          ( NIN = 5, NOUT = 6 )

      INTEGER            NSUBS

      PARAMETER          ( NSUBS = 9 )

      COMPLEX            ZERO, ONE

      PARAMETER          ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )

      REAL               RZERO, RHALF, RONE

      PARAMETER          ( RZERO = 0.0, RHALF = 0.5, RONE = 1.0 )

      INTEGER            NMAX

      PARAMETER          ( NMAX = 65 )

      INTEGER            NIDMAX, NALMAX, NBEMAX

      PARAMETER          ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 )

*     .. Local Scalars ..

      REAL               EPS, ERR, THRESH

      INTEGER            I, ISNUM, J, N, NALF, NBET, NIDIM, NTRA,

     $                   LAYOUT

      LOGICAL            FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,

     $                   TSTERR, CORDER, RORDER

      CHARACTER*1        TRANSA, TRANSB

      CHARACTER*12       SNAMET

      CHARACTER*32       SNAPS

*     .. Local Arrays ..

      COMPLEX            AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),

     $                   ALF( NALMAX ), AS( NMAX*NMAX ),

     $                   BB( NMAX*NMAX ), BET( NBEMAX ),

     $                   BS( NMAX*NMAX ), C( NMAX, NMAX ),

     $                   CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),

     $                   W( 2*NMAX )

      REAL               G( NMAX )

      INTEGER            IDIM( NIDMAX )

      LOGICAL            LTEST( NSUBS )

      CHARACTER*12       SNAMES( NSUBS )

*     .. External Functions ..

      REAL               SDIFF

      LOGICAL            LCE

      EXTERNAL           SDIFF, LCE

*     .. External Subroutines ..

      EXTERNAL         CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CMMCH

*     .. Intrinsic Functions ..

      INTRINSIC          MAX, MIN

*     .. Scalars in Common ..

      INTEGER            INFOT, NOUTC

      LOGICAL            LERR, OK

      CHARACTER*12       SRNAMT

*     .. Common blocks ..

      COMMON             /INFOC/INFOT, NOUTC, OK, LERR

      COMMON             /SRNAMC/SRNAMT

*     .. Data statements ..

      DATA               SNAMES/'cblas_cgemm ', 'cblas_chemm ',

     $                   'cblas_csymm ', 'cblas_ctrmm ', 'cblas_ctrsm ',

     $                   'cblas_cherk ', 'cblas_csyrk ', 'cblas_cher2k',

     $                   'cblas_csyr2k'/

*     .. Executable Statements ..

*

      NOUTC = NOUT

*

*     Read name and unit number for snapshot output file and open file.

*

      READ( NIN, FMT = * )SNAPS

      READ( NIN, FMT = * )NTRA

      TRACE = NTRA.GE.0

      IF( TRACE )THEN

         OPEN( NTRA, FILE = SNAPS )

      END IF

*     Read the flag that directs rewinding of the snapshot file.

      READ( NIN, FMT = * )REWI

      REWI = REWI.AND.TRACE

*     Read the flag that directs stopping on any failure.

      READ( NIN, FMT = * )SFATAL

*     Read the flag that indicates whether error exits are to be tested.

      READ( NIN, FMT = * )TSTERR

*     Read the flag that indicates whether row-major data layout to be tested.

      READ( NIN, FMT = * )LAYOUT

*     Read the threshold value of the test ratio

      READ( NIN, FMT = * )THRESH

*

*     Read and check the parameter values for the tests.

*

*     Values of N

      READ( NIN, FMT = * )NIDIM

      IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN

         WRITE( NOUT, FMT = 9997 )'N', NIDMAX

         GO TO 220

      END IF

      READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )

      DO 10 I = 1, NIDIM

         IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN

            WRITE( NOUT, FMT = 9996 )NMAX

            GO TO 220

         END IF

   10 CONTINUE

*     Values of ALPHA

      READ( NIN, FMT = * )NALF

      IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN

         WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX

         GO TO 220

      END IF

      READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )

*     Values of BETA

      READ( NIN, FMT = * )NBET

      IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN

         WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX

         GO TO 220

      END IF

      READ( NIN, FMT = * )( BET( I ), I = 1, NBET )

*

*     Report values of parameters.

*

      WRITE( NOUT, FMT = 9995 )

      WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM )

      WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF )

      WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET )

      IF( .NOT.TSTERR )THEN

         WRITE( NOUT, FMT = * )

         WRITE( NOUT, FMT = 9984 )

      END IF

      WRITE( NOUT, FMT = * )

      WRITE( NOUT, FMT = 9999 )THRESH

      WRITE( NOUT, FMT = * )

      RORDER = .FALSE.

      CORDER = .FALSE.

      IF (LAYOUT.EQ.2) THEN

         RORDER = .TRUE.

         CORDER = .TRUE.

         WRITE( *, FMT = 10002 )

      ELSE IF (LAYOUT.EQ.1) THEN

         RORDER = .TRUE.

         WRITE( *, FMT = 10001 )

      ELSE IF (LAYOUT.EQ.0) THEN

         CORDER = .TRUE.

         WRITE( *, FMT = 10000 )

      END IF

      WRITE( *, FMT = * )

*

*     Read names of subroutines and flags which indicate

*     whether they are to be tested.

*

      DO 20 I = 1, NSUBS

         LTEST( I ) = .FALSE.

   20 CONTINUE

   30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT

      DO 40 I = 1, NSUBS

         IF( SNAMET.EQ.SNAMES( I ) )

     $      GO TO 50

   40 CONTINUE

      WRITE( NOUT, FMT = 9990 )SNAMET

      STOP

   50 LTEST( I ) = LTESTT

      GO TO 30

*

   60 CONTINUE

      CLOSE ( NIN )

*

*     Compute EPS (the machine precision).

*

      EPS = RONE

   70 CONTINUE

      IF( SDIFF( RONE + EPS, RONE ).EQ.RZERO )

     $   GO TO 80

      EPS = RHALF*EPS

      GO TO 70

   80 CONTINUE

      EPS = EPS + EPS

      WRITE( NOUT, FMT = 9998 )EPS

*

*     Check the reliability of CMMCH using exact data.

*

      N = MIN( 32, NMAX )

      DO 100 J = 1, N

         DO 90 I = 1, N

            AB( I, J ) = MAX( I - J + 1, 0 )

   90    CONTINUE

         AB( J, NMAX + 1 ) = J

         AB( 1, NMAX + J ) = J

         C( J, 1 ) = ZERO

  100 CONTINUE

      DO 110 J = 1, N

         CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3

  110 CONTINUE

*     CC holds the exact result. On exit from CMMCH CT holds

*     the result computed by CMMCH.

      TRANSA = 'N'

      TRANSB = 'N'

      CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,

     $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,

     $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )

      SAME = LCE( CC, CT, N )

      IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN

         WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR

         STOP

      END IF

      TRANSB = 'C'

      CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,

     $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,

     $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )

      SAME = LCE( CC, CT, N )

      IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN

         WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR

         STOP

      END IF

      DO 120 J = 1, N

         AB( J, NMAX + 1 ) = N - J + 1

         AB( 1, NMAX + J ) = N - J + 1

  120 CONTINUE

      DO 130 J = 1, N

         CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 -

     $                     ( ( J + 1 )*J*( J - 1 ) )/3

  130 CONTINUE

      TRANSA = 'C'

      TRANSB = 'N'

      CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,

     $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,

     $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )

      SAME = LCE( CC, CT, N )

      IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN

         WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR

         STOP

      END IF

      TRANSB = 'C'

      CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,

     $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,

     $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )

      SAME = LCE( CC, CT, N )

      IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN

         WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR

         STOP

      END IF

*

*     Test each subroutine in turn.

*

      DO 200 ISNUM = 1, NSUBS

         WRITE( NOUT, FMT = * )

         IF( .NOT.LTEST( ISNUM ) )THEN

*           Subprogram is not to be tested.

            WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM )

         ELSE

            SRNAMT = SNAMES( ISNUM )

*           Test error exits.

            IF( TSTERR )THEN

               CALL CC3CHKE( SNAMES( ISNUM ) )

               WRITE( NOUT, FMT = * )

            END IF

*           Test computations.

            INFOT = 0

            OK = .TRUE.

            FATAL = .FALSE.

            GO TO ( 140, 150, 150, 160, 160, 170, 170,

     $              180, 180 )ISNUM

*           Test CGEMM, 01.

  140       IF (CORDER) THEN

            CALL CCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,

     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,

     $                 CC, CS, CT, G, 0 )

            END IF

            IF (RORDER) THEN

            CALL CCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,

     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,

     $                 CC, CS, CT, G, 1 )

            END IF

            GO TO 190

*           Test CHEMM, 02, CSYMM, 03.

  150       IF (CORDER) THEN

            CALL CCHK2(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,

     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,

     $                 CC, CS, CT, G, 0 )

            END IF

            IF (RORDER) THEN

            CALL CCHK2(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,

     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,

     $                 CC, CS, CT, G, 1 )

            END IF

            GO TO 190

*           Test CTRMM, 04, CTRSM, 05.

  160       IF (CORDER) THEN

            CALL CCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,

     $                 AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C,

     $		0 )

            END IF

            IF (RORDER) THEN

            CALL CCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,

     $                 AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C,

     $		1 )

            END IF

            GO TO 190

*           Test CHERK, 06, CSYRK, 07.

  170       IF (CORDER) THEN

            CALL CCHK4(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,

     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,

     $                 CC, CS, CT, G, 0 )

            END IF

            IF (RORDER) THEN

            CALL CCHK4(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,

     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,

     $                 CC, CS, CT, G, 1 )

            END IF

            GO TO 190

*           Test CHER2K, 08, CSYR2K, 09.

  180       IF (CORDER) THEN

            CALL CCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,

     $                 NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,

     $		0 )

            END IF

            IF (RORDER) THEN

            CALL CCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,

     $                 NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,

     $		1 )

            END IF

            GO TO 190

*

  190       IF( FATAL.AND.SFATAL )

     $         GO TO 210

         END IF

  200 CONTINUE

      WRITE( NOUT, FMT = 9986 )

      GO TO 230

*

  210 CONTINUE

      WRITE( NOUT, FMT = 9985 )

      GO TO 230

*

  220 CONTINUE

      WRITE( NOUT, FMT = 9991 )

*

  230 CONTINUE

      IF( TRACE )

     $   CLOSE ( NTRA )

      CLOSE ( NOUT )

      STOP

*

10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )

10001 FORMAT(' ROW-MAJOR DATA LAYOUT IS TESTED' )

10000 FORMAT(' COLUMN-MAJOR DATA LAYOUT IS TESTED' )

 9999 FORMAT(' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',

     $      'S THAN', F8.2 )

 9998 FORMAT(' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 )

 9997 FORMAT(' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',

     $      'THAN ', I2 )

 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )

 9995 FORMAT(' TESTS OF THE COMPLEX          LEVEL 3 BLAS', //' THE F',

     $      'OLLOWING PARAMETER VALUES WILL BE USED:' )

 9994 FORMAT( '   FOR N              ', 9I6 )

 9993 FORMAT( '   FOR ALPHA          ',

     $      7( '(', F4.1, ',', F4.1, ')  ', : ) )

 9992 FORMAT( '   FOR BETA           ',

     $      7( '(', F4.1, ',', F4.1, ')  ', : ) )

 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',

     $      /' ******* TESTS ABANDONED *******' )

 9990 FORMAT(' SUBPROGRAM NAME ', A12,' NOT RECOGNIZED', /' ******* T',

     $      'ESTS ABANDONED *******' )

 9989 FORMAT(' ERROR IN CMMCH -  IN-LINE DOT PRODUCTS ARE BEING EVALU',

     $      'ATED WRONGLY.', /' CMMCH WAS CALLED WITH TRANSA = ', A1,

     $      'AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',

     $    ' ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',

     $     'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',

     $      '*******' )

 9988 FORMAT( A12,L2 )

 9987 FORMAT( 1X, A12,' WAS NOT TESTED' )

 9986 FORMAT( /' END OF TESTS' )

 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )

 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )

*

*     End of CBLAT3.

*

      END

      SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,

     $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,

     $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G, 

     $                  IORDER )

*

*  Tests CGEMM.

*

*  Auxiliary routine for test program for Level 3 Blas.

*

*  -- Written on 8-February-1989.

*     Jack Dongarra, Argonne National Laboratory.

*     Iain Duff, AERE Harwell.

*     Jeremy Du Croz, Numerical Algorithms Group Ltd.

*     Sven Hammarling, Numerical Algorithms Group Ltd.

*

*     .. Parameters ..

      COMPLEX            ZERO

      PARAMETER          ( ZERO = ( 0.0, 0.0 ) )

      REAL               RZERO

      PARAMETER          ( RZERO = 0.0 )

*     .. Scalar Arguments ..

      REAL               EPS, THRESH

      INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER

      LOGICAL            FATAL, REWI, TRACE

      CHARACTER*12       SNAME

*     .. Array Arguments ..

      COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),

     $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),

     $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),

     $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),

     $                   CS( NMAX*NMAX ), CT( NMAX )

      REAL               G( NMAX )

      INTEGER            IDIM( NIDIM )

*     .. Local Scalars ..

      COMPLEX            ALPHA, ALS, BETA, BLS

      REAL               ERR, ERRMAX

      INTEGER            I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,

     $                   LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,

     $                   MA, MB, MS, N, NA, NARGS, NB, NC, NS

      LOGICAL            NULL, RESET, SAME, TRANA, TRANB

      CHARACTER*1        TRANAS, TRANBS, TRANSA, TRANSB

      CHARACTER*3        ICH

*     .. Local Arrays ..

      LOGICAL            ISAME( 13 )

*     .. External Functions ..

      LOGICAL            LCE, LCERES

      EXTERNAL           LCE, LCERES

*     .. External Subroutines ..

      EXTERNAL           CCGEMM, CMAKE, CMMCH

*     .. Intrinsic Functions ..

      INTRINSIC          MAX

*     .. Scalars in Common ..

      INTEGER            INFOT, NOUTC

      LOGICAL            LERR, OK

*     .. Common blocks ..

      COMMON             /INFOC/INFOT, NOUTC, OK, LERR

*     .. Data statements ..

      DATA               ICH/'NTC'/

*     .. Executable Statements ..

*

      NARGS = 13

      NC = 0

      RESET = .TRUE.

      ERRMAX = RZERO

*

      DO 110 IM = 1, NIDIM

         M = IDIM( IM )

*

         DO 100 IN = 1, NIDIM

            N = IDIM( IN )

*           Set LDC to 1 more than minimum value if room.

            LDC = M

            IF( LDC.LT.NMAX )

     $         LDC = LDC + 1

*           Skip tests if not enough room.

            IF( LDC.GT.NMAX )

     $         GO TO 100

            LCC = LDC*N

            NULL = N.LE.0.OR.M.LE.0

*

            DO 90 IK = 1, NIDIM

               K = IDIM( IK )

*

               DO 80 ICA = 1, 3

                  TRANSA = ICH( ICA: ICA )

                  TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'

*

                  IF( TRANA )THEN

                     MA = K

                     NA = M

                  ELSE

                     MA = M

                     NA = K

                  END IF

*                 Set LDA to 1 more than minimum value if room.

                  LDA = MA

                  IF( LDA.LT.NMAX )

     $               LDA = LDA + 1

*                 Skip tests if not enough room.

                  IF( LDA.GT.NMAX )

     $               GO TO 80

                  LAA = LDA*NA

*

*                 Generate the matrix A.

*

                  CALL CMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA,

     $                        RESET, ZERO )

*

                  DO 70 ICB = 1, 3

                     TRANSB = ICH( ICB: ICB )

                     TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'

*

                     IF( TRANB )THEN

                        MB = N

                        NB = K

                     ELSE

                        MB = K

                        NB = N

                     END IF

*                    Set LDB to 1 more than minimum value if room.

                     LDB = MB

                     IF( LDB.LT.NMAX )

     $                  LDB = LDB + 1

*                    Skip tests if not enough room.

                     IF( LDB.GT.NMAX )

     $                  GO TO 70

                     LBB = LDB*NB

*

*                    Generate the matrix B.

*

                     CALL CMAKE( 'ge', ' ', ' ', MB, NB, B, NMAX, BB,

     $                           LDB, RESET, ZERO )

*

                     DO 60 IA = 1, NALF

                        ALPHA = ALF( IA )

*

                        DO 50 IB = 1, NBET

                           BETA = BET( IB )

*

*                          Generate the matrix C.

*

                           CALL CMAKE( 'ge', ' ', ' ', M, N, C, NMAX,

     $                                 CC, LDC, RESET, ZERO )

*

                           NC = NC + 1

*

*                          Save every datum before calling the

*                          subroutine.

*

                           TRANAS = TRANSA

                           TRANBS = TRANSB

                           MS = M

                           NS = N

                           KS = K

                           ALS = ALPHA

                           DO 10 I = 1, LAA

                              AS( I ) = AA( I )

   10                      CONTINUE

                           LDAS = LDA

                           DO 20 I = 1, LBB

                              BS( I ) = BB( I )

   20                      CONTINUE

                           LDBS = LDB

                           BLS = BETA

                           DO 30 I = 1, LCC

                              CS( I ) = CC( I )

   30                      CONTINUE

                           LDCS = LDC

*

*                          Call the subroutine.

*

                           IF( TRACE )

     $                        CALL CPRCN1(NTRA, NC, SNAME, IORDER,

     $                        TRANSA, TRANSB, M, N, K, ALPHA, LDA,

     $                        LDB, BETA, LDC)

                           IF( REWI )

     $                        REWIND NTRA

                           CALL CCGEMM( IORDER, TRANSA, TRANSB, M, N,

     $                                 K, ALPHA, AA, LDA, BB, LDB, 

     $                                 BETA, CC, LDC )

*

*                          Check if error-exit was taken incorrectly.

*

                           IF( .NOT.OK )THEN

                              WRITE( NOUT, FMT = 9994 )

                              FATAL = .TRUE.

                              GO TO 120

                           END IF

*

*                          See what data changed inside subroutines.

*

                           ISAME( 1 ) = TRANSA.EQ.TRANAS

                           ISAME( 2 ) = TRANSB.EQ.TRANBS

                           ISAME( 3 ) = MS.EQ.M

                           ISAME( 4 ) = NS.EQ.N

                           ISAME( 5 ) = KS.EQ.K

                           ISAME( 6 ) = ALS.EQ.ALPHA

                           ISAME( 7 ) = LCE( AS, AA, LAA )

                           ISAME( 8 ) = LDAS.EQ.LDA

                           ISAME( 9 ) = LCE( BS, BB, LBB )

                           ISAME( 10 ) = LDBS.EQ.LDB

                           ISAME( 11 ) = BLS.EQ.BETA

                           IF( NULL )THEN

                              ISAME( 12 ) = LCE( CS, CC, LCC )

                           ELSE

                             ISAME( 12 ) = LCERES( 'ge', ' ', M, N, CS,

     $                                      CC, LDC )

                           END IF

                           ISAME( 13 ) = LDCS.EQ.LDC

*

*                          If data was incorrectly changed, report

*                          and return.

*

                           SAME = .TRUE.

                           DO 40 I = 1, NARGS

                              SAME = SAME.AND.ISAME( I )

                              IF( .NOT.ISAME( I ) )

     $                           WRITE( NOUT, FMT = 9998 )I

   40                      CONTINUE

                           IF( .NOT.SAME )THEN

                              FATAL = .TRUE.

                              GO TO 120

                           END IF

*

                           IF( .NOT.NULL )THEN

*

*                             Check the result.

*

                             CALL CMMCH( TRANSA, TRANSB, M, N, K,

     $                                   ALPHA, A, NMAX, B, NMAX, BETA,

     $                                   C, NMAX, CT, G, CC, LDC, EPS,

     $                                   ERR, FATAL, NOUT, .TRUE. )

                              ERRMAX = MAX( ERRMAX, ERR )

*                             If got really bad answer, report and

*                             return.

                              IF( FATAL )

     $                           GO TO 120

                           END IF

*

   50                   CONTINUE

*

   60                CONTINUE

*

   70             CONTINUE

*

   80          CONTINUE

*

   90       CONTINUE

*

  100    CONTINUE

*

  110 CONTINUE

*

*     Report result.

*

      IF( ERRMAX.LT.THRESH )THEN

         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC

         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC

      ELSE

         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX

         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX

      END IF

      GO TO 130

*

  120 CONTINUE

      WRITE( NOUT, FMT = 9996 )SNAME

      CALL CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, 

     $           M, N, K, ALPHA, LDA, LDB, BETA, LDC)

*

  130 CONTINUE

      RETURN

*

10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR    COMPUTATIONAL ',

     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',

     $ 'RATIO ', F8.2, ' - SUSPECT *******' )

10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',

     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',

     $ 'RATIO ', F8.2, ' - SUSPECT *******' )

10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR    COMPUTATIONAL TESTS',

     $ ' (', I6, ' CALL', 'S)' )

10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',

     $ ' (', I6, ' CALL', 'S)' )

 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',

     $      'ANGED INCORRECTLY *******' )

 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )

 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',',

     $     3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,

     $     ',(', F4.1, ',', F4.1, '), C,', I3, ').' )

 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',

     $      '******' )

*

*     End of CCHK1.

*

      END

*

      SUBROUTINE CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N,

     $                 K, ALPHA, LDA, LDB, BETA, LDC)

      INTEGER          NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC

      COMPLEX          ALPHA, BETA

      CHARACTER*1      TRANSA, TRANSB

      CHARACTER*12     SNAME

      CHARACTER*14     CRC, CTA,CTB

      IF (TRANSA.EQ.'N')THEN

         CTA = '  CblasNoTrans'

      ELSE IF (TRANSA.EQ.'T')THEN

         CTA = '    CblasTrans'

      ELSE 

         CTA = 'CblasConjTrans'

      END IF

      IF (TRANSB.EQ.'N')THEN

         CTB = '  CblasNoTrans'

      ELSE IF (TRANSB.EQ.'T')THEN

         CTB = '    CblasTrans'

      ELSE 

         CTB = 'CblasConjTrans'

      END IF

      IF (IORDER.EQ.1)THEN

         CRC = ' CblasRowMajor'

      ELSE 

         CRC = ' CblasColMajor'

      END IF

      WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CTA,CTB

      WRITE(NOUT, FMT = 9994)M, N, K, ALPHA, LDA, LDB, BETA, LDC

 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')

 9994 FORMAT( 10X, 3( I3, ',' ) ,' (', F4.1,',',F4.1,') , A,',

     $ I3, ', B,', I3, ', (', F4.1,',',F4.1,') , C,', I3, ').' )

      END

*

      SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,

     $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,

     $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G, 

     $                  IORDER )

*

*  Tests CHEMM and CSYMM.

*

*  Auxiliary routine for test program for Level 3 Blas.

*

*  -- Written on 8-February-1989.

*     Jack Dongarra, Argonne National Laboratory.

*     Iain Duff, AERE Harwell.

*     Jeremy Du Croz, Numerical Algorithms Group Ltd.

*     Sven Hammarling, Numerical Algorithms Group Ltd.

*

*     .. Parameters ..

      COMPLEX            ZERO

      PARAMETER          ( ZERO = ( 0.0, 0.0 ) )

      REAL               RZERO

      PARAMETER          ( RZERO = 0.0 )

*     .. Scalar Arguments ..

      REAL               EPS, THRESH

      INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER

      LOGICAL            FATAL, REWI, TRACE

      CHARACTER*12       SNAME

*     .. Array Arguments ..

      COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),

     $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),

     $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),

     $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),

     $                   CS( NMAX*NMAX ), CT( NMAX )

      REAL               G( NMAX )

      INTEGER            IDIM( NIDIM )

*     .. Local Scalars ..

      COMPLEX            ALPHA, ALS, BETA, BLS

      REAL               ERR, ERRMAX

      INTEGER            I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,

     $                   LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,

     $                   NARGS, NC, NS

      LOGICAL            CONJ, LEFT, NULL, RESET, SAME

      CHARACTER*1        SIDE, SIDES, UPLO, UPLOS

      CHARACTER*2        ICHS, ICHU

*     .. Local Arrays ..

      LOGICAL            ISAME( 13 )

*     .. External Functions ..

      LOGICAL            LCE, LCERES

      EXTERNAL           LCE, LCERES

*     .. External Subroutines ..

      EXTERNAL           CCHEMM, CMAKE, CMMCH, CCSYMM

*     .. Intrinsic Functions ..

      INTRINSIC          MAX

*     .. Scalars in Common ..

      INTEGER            INFOT, NOUTC

      LOGICAL            LERR, OK

*     .. Common blocks ..

      COMMON             /INFOC/INFOT, NOUTC, OK, LERR

*     .. Data statements ..

      DATA               ICHS/'LR'/, ICHU/'UL'/

*     .. Executable Statements ..

      CONJ = SNAME( 8: 9 ).EQ.'he'

*

      NARGS = 12

      NC = 0

      RESET = .TRUE.

      ERRMAX = RZERO

*

      DO 100 IM = 1, NIDIM

         M = IDIM( IM )

*

         DO 90 IN = 1, NIDIM

            N = IDIM( IN )

*           Set LDC to 1 more than minimum value if room.

            LDC = M

            IF( LDC.LT.NMAX )

     $         LDC = LDC + 1

*           Skip tests if not enough room.

            IF( LDC.GT.NMAX )

     $         GO TO 90

            LCC = LDC*N

            NULL = N.LE.0.OR.M.LE.0

*           Set LDB to 1 more than minimum value if room.

            LDB = M

            IF( LDB.LT.NMAX )

     $         LDB = LDB + 1

*           Skip tests if not enough room.

            IF( LDB.GT.NMAX )

     $         GO TO 90

            LBB = LDB*N

*

*           Generate the matrix B.

*

            CALL CMAKE( 'ge', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET,

     $                  ZERO )

*

            DO 80 ICS = 1, 2

               SIDE = ICHS( ICS: ICS )

               LEFT = SIDE.EQ.'L'

*

               IF( LEFT )THEN

                  NA = M

               ELSE

                  NA = N

               END IF

*              Set LDA to 1 more than minimum value if room.

               LDA = NA

               IF( LDA.LT.NMAX )

     $            LDA = LDA + 1

*              Skip tests if not enough room.

               IF( LDA.GT.NMAX )

     $            GO TO 80

               LAA = LDA*NA

*

               DO 70 ICU = 1, 2

                  UPLO = ICHU( ICU: ICU )

*

*                 Generate the hermitian or symmetric matrix A.

*

                  CALL CMAKE(SNAME( 8: 9 ), UPLO, ' ', NA, NA, A, NMAX,

     $                        AA, LDA, RESET, ZERO )

*

                  DO 60 IA = 1, NALF

                     ALPHA = ALF( IA )

*

                     DO 50 IB = 1, NBET