PROGRAM ZBLAT2

*

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

*

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

*  of the file are read using list-directed input, the last 17 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 35 lines:

*  'ZBLAT2.SUMM'     NAME OF SUMMARY OUTPUT FILE

*  6                 UNIT NUMBER OF SUMMARY FILE

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

*  4                 NUMBER OF VALUES OF K

*  0 1 2 4           VALUES OF K

*  4                 NUMBER OF VALUES OF INCX AND INCY

*  1 2 -1 -2         VALUES OF INCX AND INCY

*  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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

*

*     See:

*

*        Dongarra J. J., Du Croz J. J., Hammarling S.  and Hanson R. J..

*        An  extended  set of Fortran  Basic Linear Algebra Subprograms.

*

*        Technical  Memoranda  Nos. 41 (revision 3) and 81,  Mathematics

*        and  Computer Science  Division,  Argonne  National Laboratory,

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

*

*        Or

*

*        NAG  Technical Reports TR3/87 and TR4/87,  Numerical Algorithms

*        Group  Ltd.,  NAG  Central  Office,  256  Banbury  Road, Oxford

*        OX2 7DE, UK,  and  Numerical Algorithms Group Inc.,  1101  31st

*        Street,  Suite 100,  Downers Grove,  Illinois 60515-1263,  USA.

*

*

*  -- Written on 10-August-1987.

*     Richard Hanson, Sandia National Labs.

*     Jeremy Du Croz, NAG Central Office.

*

*     .. Parameters ..

      INTEGER            NIN

      PARAMETER          ( NIN = 5 )

      INTEGER            NSUBS

      PARAMETER          ( NSUBS = 17 )

      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, INCMAX

      PARAMETER          ( NMAX = 65, INCMAX = 2 )

      INTEGER            NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX

      PARAMETER          ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7,

     $                   NALMAX = 7, NBEMAX = 7 )

*     .. Local Scalars ..

      DOUBLE PRECISION   EPS, ERR, THRESH

      INTEGER            I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,

     $                   NOUT, NTRA

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

     $                   TSTERR

      CHARACTER*1        TRANS

      CHARACTER*6        SNAMET

      CHARACTER*32       SNAPS, SUMMRY

*     .. Local Arrays ..

      COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ),

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

     $                   X( NMAX ), XS( NMAX*INCMAX ),

     $                   XX( NMAX*INCMAX ), Y( NMAX ),

     $                   YS( NMAX*INCMAX ), YT( NMAX ),

     $                   YY( NMAX*INCMAX ), Z( 2*NMAX )

      DOUBLE PRECISION   G( NMAX )

      INTEGER            IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )

      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, ZCHK6,

     $                   ZCHKE, ZMVCH

*     .. Intrinsic Functions ..

      INTRINSIC          ABS, 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/'ZGEMV ', 'ZGBMV ', 'ZHEMV ', 'ZHBMV ',

     $                   'ZHPMV ', 'ZTRMV ', 'ZTBMV ', 'ZTPMV ',

     $                   'ZTRSV ', 'ZTBSV ', 'ZTPSV ', 'ZGERC ',

     $                   'ZGERU ', 'ZHER  ', 'ZHPR  ', 'ZHER2 ',

     $                   'ZHPR2 '/

*     .. 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 230

      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 230

         END IF

   10 CONTINUE

*     Values of K

      READ( NIN, FMT = * )NKB

      IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN

         WRITE( NOUT, FMT = 9997 )'K', NKBMAX

         GO TO 230

      END IF

      READ( NIN, FMT = * )( KB( I ), I = 1, NKB )

      DO 20 I = 1, NKB

         IF( KB( I ).LT.0 )THEN

            WRITE( NOUT, FMT = 9995 )

            GO TO 230

         END IF

   20 CONTINUE

*     Values of INCX and INCY

      READ( NIN, FMT = * )NINC

      IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN

         WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX

         GO TO 230

      END IF

      READ( NIN, FMT = * )( INC( I ), I = 1, NINC )

      DO 30 I = 1, NINC

         IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN

            WRITE( NOUT, FMT = 9994 )INCMAX

            GO TO 230

         END IF

   30 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 230

      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 230

      END IF

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

*

*     Report values of parameters.

*

      WRITE( NOUT, FMT = 9993 )

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

      WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB )

      WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC )

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

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

      IF( .NOT.TSTERR )THEN

         WRITE( NOUT, FMT = * )

         WRITE( NOUT, FMT = 9980 )

      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 40 I = 1, NSUBS

         LTEST( I ) = .FALSE.

   40 CONTINUE

   50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT

      DO 60 I = 1, NSUBS

         IF( SNAMET.EQ.SNAMES( I ) )

     $      GO TO 70

   60 CONTINUE

      WRITE( NOUT, FMT = 9986 )SNAMET

      STOP

   70 LTEST( I ) = LTESTT

      GO TO 50

*

   80 CONTINUE

      CLOSE ( NIN )

*

*     Compute EPS (the machine precision).

*

      EPS = RONE

   90 CONTINUE

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

     $   GO TO 100

      EPS = RHALF*EPS

      GO TO 90

  100 CONTINUE

      EPS = EPS + EPS

      WRITE( NOUT, FMT = 9998 )EPS

*

*     Check the reliability of ZMVCH using exact data.

*

      N = MIN( 32, NMAX )

      DO 120 J = 1, N

         DO 110 I = 1, N

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

  110    CONTINUE

         X( J ) = J

         Y( J ) = ZERO

  120 CONTINUE

      DO 130 J = 1, N

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

  130 CONTINUE

*     YY holds the exact result. On exit from ZMVCH YT holds

*     the result computed by ZMVCH.

      TRANS = 'N'

      CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,

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

      SAME = LZE( YY, YT, N )

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

         WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR

         STOP

      END IF

      TRANS = 'T'

      CALL ZMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,

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

      SAME = LZE( YY, YT, N )

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

         WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR

         STOP

      END IF

*

*     Test each subroutine in turn.

*

      DO 210 ISNUM = 1, NSUBS

         WRITE( NOUT, FMT = * )

         IF( .NOT.LTEST( ISNUM ) )THEN

*           Subprogram is not to be tested.

            WRITE( NOUT, FMT = 9983 )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, 140, 150, 150, 150, 160, 160,

     $              160, 160, 160, 160, 170, 170, 180,

     $              180, 190, 190 )ISNUM

*           Test ZGEMV, 01, and ZGBMV, 02.

  140       CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,

     $                  NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,

     $                  X, XX, XS, Y, YY, YS, YT, G )

            GO TO 200

*           Test ZHEMV, 03, ZHBMV, 04, and ZHPMV, 05.

  150       CALL ZCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,

     $                  NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,

     $                  X, XX, XS, Y, YY, YS, YT, G )

            GO TO 200

*           Test ZTRMV, 06, ZTBMV, 07, ZTPMV, 08,

*           ZTRSV, 09, ZTBSV, 10, and ZTPSV, 11.

  160       CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                  REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,

     $                  NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z )

            GO TO 200

*           Test ZGERC, 12, ZGERU, 13.

  170       CALL ZCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,

     $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,

     $                  YT, G, Z )

            GO TO 200

*           Test ZHER, 14, and ZHPR, 15.

  180       CALL ZCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,

     $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,

     $                  YT, G, Z )

            GO TO 200

*           Test ZHER2, 16, and ZHPR2, 17.

  190       CALL ZCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,

     $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,

     $                  NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,

     $                  YT, G, Z )

*

  200       IF( FATAL.AND.SFATAL )

     $         GO TO 220

         END IF

  210 CONTINUE

      WRITE( NOUT, FMT = 9982 )

      GO TO 240

*

  220 CONTINUE

      WRITE( NOUT, FMT = 9981 )

      GO TO 240

*

  230 CONTINUE

      WRITE( NOUT, FMT = 9987 )

*

  240 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( ' VALUE OF K IS LESS THAN 0' )

 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',

     $      I2 )

 9993 FORMAT( ' TESTS OF THE COMPLEX*16       LEVEL 2 BLAS', //' THE F',

     $      'OLLOWING PARAMETER VALUES WILL BE USED:' )

 9992 FORMAT( '   FOR N              ', 9I6 )

 9991 FORMAT( '   FOR K              ', 7I6 )

 9990 FORMAT( '   FOR INCX AND INCY  ', 7I6 )

 9989 FORMAT( '   FOR ALPHA          ',

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

 9988 FORMAT( '   FOR BETA           ',

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

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

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

 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',

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

 9985 FORMAT( ' ERROR IN ZMVCH -  IN-LINE DOT PRODUCTS ARE BEING EVALU',

     $      'ATED WRONGLY.', /' ZMVCH WAS CALLED WITH TRANS = ', A1,

     $      ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', /

     $   ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'

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

 9984 FORMAT( A6, L2 )

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

 9982 FORMAT( /' END OF TESTS' )

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

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

*

*     End of ZBLAT2.

*

      END

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

     $                  FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,

     $                  BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,

     $                  XS, Y, YY, YS, YT, G )

*

*  Tests ZGEMV and ZGBMV.

*

*  Auxiliary routine for test program for Level 2 Blas.

*

*  -- Written on 10-August-1987.

*     Richard Hanson, Sandia National Labs.

*     Jeremy Du Croz, NAG Central Office.

*

*     .. Parameters ..

      COMPLEX*16         ZERO, HALF

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

     $                   HALF = ( 0.5D0, 0.0D0 ) )

      DOUBLE PRECISION   RZERO

      PARAMETER          ( RZERO = 0.0D0 )

*     .. Scalar Arguments ..

      DOUBLE PRECISION   EPS, THRESH

      INTEGER            INCMAX, NALF, NBET, NIDIM, NINC, NKB, 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 ), BET( NBET ), X( NMAX ),

     $                   XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),

     $                   Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),

     $                   YY( NMAX*INCMAX )

      DOUBLE PRECISION   G( NMAX )

      INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )

*     .. Local Scalars ..

      COMPLEX*16         ALPHA, ALS, BETA, BLS, TRANSL

      DOUBLE PRECISION   ERR, ERRMAX

      INTEGER            I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,

     $                   INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,

     $                   LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,

     $                   NL, NS

      LOGICAL            BANDED, FULL, NULL, RESET, SAME, TRAN

      CHARACTER*1        TRANS, TRANSS

      CHARACTER*3        ICH

*     .. Local Arrays ..

      LOGICAL            ISAME( 13 )

*     .. External Functions ..

      LOGICAL            LZE, LZERES

      EXTERNAL           LZE, LZERES

*     .. External Subroutines ..

      EXTERNAL           ZGBMV, ZGEMV, ZMAKE, ZMVCH

*     .. Intrinsic Functions ..

      INTRINSIC          ABS, MAX, MIN

*     .. Scalars in Common ..

      INTEGER            INFOT, NOUTC

      LOGICAL            LERR, OK

*     .. Common blocks ..

      COMMON             /INFOC/INFOT, NOUTC, OK, LERR

*     .. Data statements ..

      DATA               ICH/'NTC'/

*     .. Executable Statements ..

      FULL = SNAME( 3: 3 ).EQ.'E'

      BANDED = SNAME( 3: 3 ).EQ.'B'

*     Define the number of arguments.

      IF( FULL )THEN

         NARGS = 11

      ELSE IF( BANDED )THEN

         NARGS = 13

      END IF

*

      NC = 0

      RESET = .TRUE.

      ERRMAX = RZERO

*

      DO 120 IN = 1, NIDIM

         N = IDIM( IN )

         ND = N/2 + 1

*

         DO 110 IM = 1, 2

            IF( IM.EQ.1 )

     $         M = MAX( N - ND, 0 )

            IF( IM.EQ.2 )

     $         M = MIN( N + ND, NMAX )

*

            IF( BANDED )THEN

               NK = NKB

            ELSE

               NK = 1

            END IF

            DO 100 IKU = 1, NK

               IF( BANDED )THEN

                  KU = KB( IKU )

                  KL = MAX( KU - 1, 0 )

               ELSE

                  KU = N - 1

                  KL = M - 1

               END IF

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

               IF( BANDED )THEN

                  LDA = KL + KU + 1

               ELSE

                  LDA = M

               END IF

               IF( LDA.LT.NMAX )

     $            LDA = LDA + 1

*              Skip tests if not enough room.

               IF( LDA.GT.NMAX )

     $            GO TO 100

               LAA = LDA*N

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

*

*              Generate the matrix A.

*

               TRANSL = ZERO

               CALL ZMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA,

     $                     LDA, KL, KU, RESET, TRANSL )

*

               DO 90 IC = 1, 3

                  TRANS = ICH( IC: IC )

                  TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'

*

                  IF( TRAN )THEN

                     ML = N

                     NL = M

                  ELSE

                     ML = M

                     NL = N

                  END IF

*

                  DO 80 IX = 1, NINC

                     INCX = INC( IX )

                     LX = ABS( INCX )*NL

*

*                    Generate the vector X.

*

                     TRANSL = HALF

                     CALL ZMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX,

     $                           ABS( INCX ), 0, NL - 1, RESET, TRANSL )

                     IF( NL.GT.1 )THEN

                        X( NL/2 ) = ZERO

                        XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO

                     END IF

*

                     DO 70 IY = 1, NINC

                        INCY = INC( IY )

                        LY = ABS( INCY )*ML

*

                        DO 60 IA = 1, NALF

                           ALPHA = ALF( IA )

*

                           DO 50 IB = 1, NBET

                              BETA = BET( IB )

*

*                             Generate the vector Y.

*

                              TRANSL = ZERO

                              CALL ZMAKE( 'GE', ' ', ' ', 1, ML, Y, 1,

     $                                    YY, ABS( INCY ), 0, ML - 1,

     $                                    RESET, TRANSL )

*

                              NC = NC + 1

*

*                             Save every datum before calling the

*                             subroutine.

*

                              TRANSS = TRANS

                              MS = M

                              NS = N

                              KLS = KL

                              KUS = KU

                              ALS = ALPHA

                              DO 10 I = 1, LAA

                                 AS( I ) = AA( I )

   10                         CONTINUE

                              LDAS = LDA

                              DO 20 I = 1, LX

                                 XS( I ) = XX( I )

   20                         CONTINUE

                              INCXS = INCX

                              BLS = BETA

                              DO 30 I = 1, LY

                                 YS( I ) = YY( I )

   30                         CONTINUE

                              INCYS = INCY

*

*                             Call the subroutine.

*

                              IF( FULL )THEN

                                 IF( TRACE )

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

     $                              TRANS, M, N, ALPHA, LDA, INCX, BETA,

     $                              INCY

                                 IF( REWI )

     $                              REWIND NTRA

                                 CALL ZGEMV( TRANS, M, N, ALPHA, AA,

     $                                       LDA, XX, INCX, BETA, YY,

     $                                       INCY )

                              ELSE IF( BANDED )THEN

                                 IF( TRACE )

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

     $                              TRANS, M, N, KL, KU, ALPHA, LDA,

     $                              INCX, BETA, INCY

                                 IF( REWI )

     $                              REWIND NTRA

                                 CALL ZGBMV( TRANS, M, N, KL, KU, ALPHA,

     $                                       AA, LDA, XX, INCX, BETA,

     $                                       YY, INCY )

                              END IF

*

*                             Check if error-exit was taken incorrectly.

*

                              IF( .NOT.OK )THEN

                                 WRITE( NOUT, FMT = 9993 )

                                 FATAL = .TRUE.

                                 GO TO 130

                              END IF

*

*                             See what data changed inside subroutines.

*

                              ISAME( 1 ) = TRANS.EQ.TRANSS

                              ISAME( 2 ) = MS.EQ.M

                              ISAME( 3 ) = NS.EQ.N

                              IF( FULL )THEN

                                 ISAME( 4 ) = ALS.EQ.ALPHA

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

                                 ISAME( 6 ) = LDAS.EQ.LDA

                                 ISAME( 7 ) = LZE( XS, XX, LX )

                                 ISAME( 8 ) = INCXS.EQ.INCX

                                 ISAME( 9 ) = BLS.EQ.BETA

                                 IF( NULL )THEN

                                    ISAME( 10 ) = LZE( YS, YY, LY )

                                 ELSE

                                    ISAME( 10 ) = LZERES( 'GE', ' ', 1,

     $                                            ML, YS, YY,

     $                                            ABS( INCY ) )

                                 END IF

                                 ISAME( 11 ) = INCYS.EQ.INCY

                              ELSE IF( BANDED )THEN

                                 ISAME( 4 ) = KLS.EQ.KL

                                 ISAME( 5 ) = KUS.EQ.KU

                                 ISAME( 6 ) = ALS.EQ.ALPHA

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

                                 ISAME( 8 ) = LDAS.EQ.LDA

                                 ISAME( 9 ) = LZE( XS, XX, LX )

                                 ISAME( 10 ) = INCXS.EQ.INCX

                                 ISAME( 11 ) = BLS.EQ.BETA

                                 IF( NULL )THEN

                                    ISAME( 12 ) = LZE( YS, YY, LY )

                                 ELSE

                                    ISAME( 12 ) = LZERES( 'GE', ' ', 1,

     $                                            ML, YS, YY,

     $                                            ABS( INCY ) )

                                 END IF

                                 ISAME( 13 ) = INCYS.EQ.INCY

                              END IF

*

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

                              END IF

*

                              IF( .NOT.NULL )THEN

*

*                                Check the result.

*

                                 CALL ZMVCH( TRANS, M, N, ALPHA, A,

     $                                       NMAX, X, INCX, BETA, Y,

     $                                       INCY, YT, G, YY, EPS, ERR,

     $                                       FATAL, NOUT, .TRUE. )

                                 ERRMAX = MAX( ERRMAX, ERR )

*                                If got really bad answer, report and

*                                return.

                                 IF( FATAL )

     $                              GO TO 130

                              ELSE

*                                Avoid repeating tests with M.le.0 or

*                                N.le.0.

                                 GO TO 110

                              END IF

*

   50                      CONTINUE

*

   60                   CONTINUE

*

   70                CONTINUE

*

   80             CONTINUE

*

   90          CONTINUE

*

  100       CONTINUE

*

  110    CONTINUE

*

  120 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 140

*

  130 CONTINUE

      WRITE( NOUT, FMT = 9996 )SNAME

      IF( FULL )THEN

         WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA,

     $      INCX, BETA, INCY

      ELSE IF( BANDED )THEN

         WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU,

     $      ALPHA, LDA, INCX, BETA, INCY

      END IF

*

  140 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, ''',', 4( I3, ',' ), '(',

     $      F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',

     $      F4.1, '), Y,', I2, ') .' )

 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(',

     $      F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',

     $      F4.1, '), Y,', I2, ')         .' )

 9993 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, NKB, KB, NALF, ALF, NBET,

     $                  BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,

     $                  XS, Y, YY, YS, YT, G )

*

*  Tests ZHEMV, ZHBMV and ZHPMV.

*

*  Auxiliary routine for test program for Level 2 Blas.

*

*  -- Written on 10-August-1987.

*     Richard Hanson, Sandia National Labs.

*     Jeremy Du Croz, NAG Central Office.

*

*     .. Parameters ..

      COMPLEX*16         ZERO, HALF

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

     $                   HALF = ( 0.5D0, 0.0D0 ) )

      DOUBLE PRECISION   RZERO

      PARAMETER          ( RZERO = 0.0D0 )

*     .. Scalar Arguments ..

      DOUBLE PRECISION   EPS, THRESH

      INTEGER            INCMAX, NALF, NBET, NIDIM, NINC, NKB, 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 ), BET( NBET ), X( NMAX ),

     $                   XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),

     $                   Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),

     $                   YY( NMAX*INCMAX )

      DOUBLE PRECISION   G( NMAX )

      INTEGER            IDIM( NIDIM ), INC( NINC ), KB( NKB )

*     .. Local Scalars ..

      COMPLEX*16         ALPHA, ALS, BETA, BLS, TRANSL

      DOUBLE PRECISION   ERR, ERRMAX

      INTEGER            I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,

     $                   INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,

     $                   N, NARGS, NC, NK, NS

      LOGICAL            BANDED, FULL, NULL, PACKED, RESET, SAME

      CHARACTER*1        UPLO, UPLOS

      CHARACTER*2        ICH

*     .. Local Arrays ..

      LOGICAL            ISAME( 13 )

*     .. External Functions ..

      LOGICAL            LZE, LZERES

      EXTERNAL           LZE, LZERES

*     .. External Subroutines ..

      EXTERNAL           ZHBMV, ZHEMV, ZHPMV, ZMAKE, ZMVCH

*     .. Intrinsic Functions ..

      INTRINSIC          ABS, MAX

*     .. Scalars in Common ..

      INTEGER            INFOT, NOUTC

      LOGICAL            LERR, OK

*     .. Common blocks ..

      COMMON             /INFOC/INFOT, NOUTC, OK, LERR

*     .. Data statements ..

      DATA               ICH/'UL'/

*     .. Executable Statements ..

      FULL = SNAME( 3: 3 ).EQ.'E'

      BANDED = SNAME( 3: 3 ).EQ.'B'

      PACKED = SNAME( 3: 3 ).EQ.'P'

*     Define the number of arguments.

      IF( FULL )THEN

         NARGS = 10

      ELSE IF( BANDED )THEN

         NARGS = 11

      ELSE IF( PACKED )THEN

         NARGS = 9

      END IF

*

      NC = 0

      RESET = .TRUE.

      ERRMAX = RZERO

*

      DO 110 IN = 1, NIDIM

         N = IDIM( IN )

*

         IF( BANDED )THEN

            NK = NKB

         ELSE

            NK = 1

         END IF

         DO 100 IK = 1, NK

            IF( BANDED )THEN

               K = KB( IK )

            ELSE

               K = N - 1

            END IF

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

            IF( BANDED )THEN

               LDA = K + 1

            ELSE

               LDA = N

            END IF

            IF( LDA.LT.NMAX )

     $         LDA = LDA + 1

*           Skip tests if not enough room.

            IF( LDA.GT.NMAX )

     $         GO TO 100

            IF( PACKED )THEN

               LAA = ( N*( N + 1 ) )/2

            ELSE

               LAA = LDA*N

            END IF

            NULL = N.LE.0

*

            DO 90 IC = 1, 2

               UPLO = ICH( IC: IC )

*

*              Generate the matrix A.

*

               TRANSL = ZERO

               CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA,

     $                     LDA, K, K, RESET, TRANSL )

*

               DO 80 IX = 1, NINC

                  INCX = INC( IX )

                  LX = ABS( INCX )*N

*

*                 Generate the vector X.

*

                  TRANSL = HALF

                  CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,

     $                        ABS( INCX ), 0, N - 1, RESET, TRANSL )

                  IF( N.GT.1 )THEN

                     X( N/2 ) = ZERO

                     XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO

                  END IF

*

                  DO 70 IY = 1, NINC

                     INCY = INC( IY )

                     LY = ABS( INCY )*N

*