PROGRAM ZBLAT3

*

*  Test program for the COMPLEX*16       Level 3 Blas.

*

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

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

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

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

*  following 23 lines:

*  'ZBLAT3.SUMM'     NAME OF SUMMARY OUTPUT FILE

*  6                 UNIT NUMBER OF SUMMARY FILE

*  'ZBLAT3.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.

*  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

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

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

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

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

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

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

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

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

*  ZSYR2K 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

      PARAMETER          ( NIN = 5 )

      INTEGER            NSUBS

      PARAMETER          ( NSUBS = 9 )

      COMPLEX*16         ZERO, ONE

      PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ),

     $                   ONE = ( 1.0D0, 0.0D0 ) )

      DOUBLE PRECISION   RZERO, RHALF, RONE

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

      INTEGER            NMAX

      PARAMETER          ( NMAX = 65 )

      INTEGER            NIDMAX, NALMAX, NBEMAX

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

*     .. Local Scalars ..

      DOUBLE PRECISION   EPS, ERR, THRESH

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

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

     $                   TSTERR

      CHARACTER*1        TRANSA, TRANSB

      CHARACTER*6        SNAMET

      CHARACTER*32       SNAPS, SUMMRY

*     .. Local Arrays ..

      COMPLEX*16         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 )

      DOUBLE PRECISION   G( NMAX )

      INTEGER            IDIM( NIDMAX )

      LOGICAL            LTEST( NSUBS )

      CHARACTER*6        SNAMES( NSUBS )

*     .. External Functions ..

      DOUBLE PRECISION   DDIFF

      LOGICAL            LZE

      EXTERNAL           DDIFF, LZE

*     .. External Subroutines ..

      EXTERNAL           ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHKE, ZMMCH

*     .. Intrinsic Functions ..

      INTRINSIC          MAX, MIN

*     .. Scalars in Common ..

      INTEGER            INFOT, NOUTC

      LOGICAL            LERR, OK

      CHARACTER*6        SRNAMT

*     .. Common blocks ..

      COMMON             /INFOC/INFOT, NOUTC, OK, LERR

      COMMON             /SRNAMC/SRNAMT

*     .. Data statements ..

      DATA               SNAMES/'ZGEMM ', 'ZHEMM ', 'ZSYMM ', 'ZTRMM ',

     $                   'ZTRSM ', 'ZHERK ', 'ZSYRK ', 'ZHER2K',

     $                   'ZSYR2K'/

*     .. Executable Statements ..

*

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

*

      READ( NIN, FMT = * )SUMMRY

      READ( NIN, FMT = * )NOUT

      OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )

      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, STATUS = 'NEW' )

      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 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 = * )

*

*     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( DDIFF( 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 ZMMCH 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 ZMMCH CT holds

*     the result computed by ZMMCH.

      TRANSA = 'N'

      TRANSB = 'N'

      CALL ZMMCH( 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 = LZE( 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 ZMMCH( 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 = LZE( 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 ZMMCH( 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 = LZE( 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 ZMMCH( 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 = LZE( 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 ZCHKE( ISNUM, SNAMES( ISNUM ), NOUT )

               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 ZGEMM, 01.

  140       CALL ZCHK1( 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 )

            GO TO 190

*           Test ZHEMM, 02, ZSYMM, 03.

  150       CALL ZCHK2( 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 )

            GO TO 190

*           Test ZTRMM, 04, ZTRSM, 05.

  160       CALL ZCHK3( 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 )

            GO TO 190

*           Test ZHERK, 06, ZSYRK, 07.

  170       CALL ZCHK4( 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 )

            GO TO 190

*           Test ZHER2K, 08, ZSYR2K, 09.

  180       CALL ZCHK5( 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 )

            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

*

 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, D9.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*16       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 ', A6, ' NOT RECOGNIZED', /' ******* T',

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

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

     $      'ATED WRONGLY.', /' ZMMCH 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( A6, L2 )

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

 9986 FORMAT( /' END OF TESTS' )

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

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

*

*     End of ZBLAT3.

*

      END

      SUBROUTINE ZCHK1( 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 )

*

*  Tests ZGEMM.

*

*  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*16         ZERO

      PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ) )

      DOUBLE PRECISION   RZERO

      PARAMETER          ( RZERO = 0.0D0 )

*     .. Scalar Arguments ..

      DOUBLE PRECISION   EPS, THRESH

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

      LOGICAL            FATAL, REWI, TRACE

      CHARACTER*6        SNAME

*     .. Array Arguments ..

      COMPLEX*16         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 )

      DOUBLE PRECISION   G( NMAX )

      INTEGER            IDIM( NIDIM )

*     .. Local Scalars ..

      COMPLEX*16         ALPHA, ALS, BETA, BLS

      DOUBLE PRECISION   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            LZE, LZERES

      EXTERNAL           LZE, LZERES

*     .. External Subroutines ..

      EXTERNAL           ZGEMM, ZMAKE, ZMMCH

*     .. 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 ZMAKE( '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 ZMAKE( '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 ZMAKE( '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 )

     $                        WRITE( NTRA, FMT = 9995 )NC, SNAME,

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

     $                        BETA, LDC

                           IF( REWI )

     $                        REWIND NTRA

                           CALL ZGEMM( 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 ) = LZE( AS, AA, LAA )

                           ISAME( 8 ) = LDAS.EQ.LDA

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

                           ISAME( 10 ) = LDBS.EQ.LDB

                           ISAME( 11 ) = BLS.EQ.BETA

                           IF( NULL )THEN

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

                           ELSE

                              ISAME( 12 ) = LZERES( '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 ZMMCH( 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

         WRITE( NOUT, FMT = 9999 )SNAME, NC

      ELSE

         WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX

      END IF

      GO TO 130

*

  120 CONTINUE

      WRITE( NOUT, FMT = 9996 )SNAME

      WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K,

     $   ALPHA, LDA, LDB, BETA, LDC

*

  130 CONTINUE

      RETURN

*

 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',

     $      'S)' )

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

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

 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',

     $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,

     $      ' - SUSPECT *******' )

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

 9995 FORMAT( 1X, I6, ': ', A6, '(''', 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 ZCHK1.

*

      END

      SUBROUTINE ZCHK2( 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 )

*

*  Tests ZHEMM and ZSYMM.

*

*  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*16         ZERO

      PARAMETER          ( ZERO = ( 0.0D0, 0.0D0 ) )

      DOUBLE PRECISION   RZERO

      PARAMETER          ( RZERO = 0.0D0 )

*     .. Scalar Arguments ..

      DOUBLE PRECISION   EPS, THRESH

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

      LOGICAL            FATAL, REWI, TRACE

      CHARACTER*6        SNAME

*     .. Array Arguments ..

      COMPLEX*16         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 )

      DOUBLE PRECISION   G( NMAX )

      INTEGER            IDIM( NIDIM )

*     .. Local Scalars ..

      COMPLEX*16         ALPHA, ALS, BETA, BLS

      DOUBLE PRECISION   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            LZE, LZERES

      EXTERNAL           LZE, LZERES

*     .. External Subroutines ..

      EXTERNAL           ZHEMM, ZMAKE, ZMMCH, ZSYMM

*     .. 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( 2: 3 ).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 ZMAKE( '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 ZMAKE( SNAME( 2: 3 ), UPLO, ' ', NA, NA, A, NMAX,

     $                        AA, LDA, RESET, ZERO )

*

                  DO 60 IA = 1, NALF

                     ALPHA = ALF( IA )

*

                     DO 50 IB = 1, NBET

                        BETA = BET( IB )

*

*                       Generate the matrix C.

*

                        CALL ZMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC,

     $                              LDC, RESET, ZERO )

*

                        NC = NC + 1

*

*                       Save every datum before calling the

*                       subroutine.

*

                        SIDES = SIDE

                        UPLOS = UPLO

                        MS = M

                        NS = N

                        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 )

     $                     WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE,

     $                     UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC

                        IF( REWI )

     $                     REWIND NTRA

                        IF( CONJ )THEN

                           CALL ZHEMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,

     $                                 BB, LDB, BETA, CC, LDC )

                        ELSE

                           CALL ZSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,

     $                                 BB, LDB, BETA, CC, LDC )

                        END IF

*

*                       Check if error-exit was taken incorrectly.

*

                        IF( .NOT.OK )THEN

                           WRITE( NOUT, FMT = 9994 )

                           FATAL = .TRUE.

                           GO TO 110

                        END IF

*

*                       See what data changed inside subroutines.

*

                        ISAME( 1 ) = SIDES.EQ.SIDE

                        ISAME( 2 ) = UPLOS.EQ.UPLO

                        ISAME( 3 ) = MS.EQ.M

                        ISAME( 4 ) = NS.EQ.N

                        ISAME( 5 ) = ALS.EQ.ALPHA

                        ISAME( 6 ) = LZE( AS, AA, LAA )

                        ISAME( 7 ) = LDAS.EQ.LDA

                        ISAME( 8 ) = LZE( BS, BB, LBB )

                        ISAME( 9 ) = LDBS.EQ.LDB

                        ISAME( 10 ) = BLS.EQ.BETA

                        IF( NULL )THEN

                           ISAME( 11 ) = LZE( CS, CC, LCC )

                        ELSE

                           ISAME( 11 ) = LZERES( 'GE', ' ', M, N, CS,

     $                                   CC, LDC )

                        END IF

                        ISAME( 12 ) = 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 110

                        END IF

*

                        IF( .NOT.NULL )THEN

*

*                          Check the result.

*

                           IF( LEFT )THEN

                              CALL ZMMCH( 'N', 'N', M, N, M, ALPHA, A,

     $                                    NMAX, B, NMAX, BETA, C, NMAX,

     $                                    CT, G, CC, LDC, EPS, ERR,

     $                                    FATAL, NOUT, .TRUE. )

                           ELSE

                              CALL ZMMCH( 'N', 'N', M, N, N, ALPHA, B,

     $                                    NMAX, A, NMAX, BETA, C, NMAX,

     $                                    CT, G, CC, LDC, EPS, ERR,

     $                                    FATAL, NOUT, .TRUE. )

                           END IF

                           ERRMAX = MAX( ERRMAX, ERR )