PROGRAM CBLAT2

*

*  Test program for the COMPLEX          Level 2 Blas.

*

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

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

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

*  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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

*  cblas_chpr2  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, NOUT

      PARAMETER          ( NIN = 5, NOUT = 6 )

      INTEGER            NSUBS

      PARAMETER          ( NSUBS = 17 )

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

      REAL               EPS, ERR, THRESH

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

     $                   NTRA, LAYOUT

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

     $                   TSTERR, CORDER, RORDER

      CHARACTER*1        TRANS

      CHARACTER*12       SNAMET

      CHARACTER*32       SNAPS

*     .. Local Arrays ..

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

      REAL               G( NMAX )

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

      LOGICAL            LTEST( NSUBS )

      CHARACTER*12       SNAMES( NSUBS )

*     .. External Functions ..

      REAL               SDIFF

      LOGICAL            LCE

      EXTERNAL           SDIFF, LCE

*     .. External Subroutines ..

      EXTERNAL           CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHK6,

     $                   CC2CHKE, CMVCH

*     .. Intrinsic Functions ..

      INTRINSIC          ABS, MAX, MIN

*     .. Scalars in Common ..

      INTEGER            INFOT, NOUTC

      LOGICAL            OK

      CHARACTER*12       SRNAMT

*     .. Common blocks ..

      COMMON             /INFOC/INFOT, NOUTC, OK

      COMMON             /SRNAMC/SRNAMT

*     .. Data statements ..

      DATA               SNAMES/'cblas_cgemv ', 'cblas_cgbmv ',

     $                   'cblas_chemv ','cblas_chbmv ','cblas_chpmv ',

     $                   'cblas_ctrmv ','cblas_ctbmv ','cblas_ctpmv ',

     $                   'cblas_ctrsv ','cblas_ctbsv ','cblas_ctpsv ',

     $                   'cblas_cgerc ','cblas_cgeru ','cblas_cher  ',

     $                   'cblas_chpr  ','cblas_cher2 ','cblas_chpr2 '/

*     .. Executable Statements ..

*

      NOUTC = NOUT

*

*     Read name and unit number for summary 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 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 = * )

      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 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( SDIFF( 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 CMVCH 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 CMVCH YT holds

*     the result computed by CMVCH.

      TRANS = 'N'

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

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

      SAME = LCE( YY, YT, N )

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

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

         STOP

      END IF

      TRANS = 'T'

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

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

      SAME = LCE( 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 CC2CHKE( SNAMES( ISNUM ) )

               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 CGEMV, 01, and CGBMV, 02.

  140       IF (CORDER) THEN

            CALL CCHK1( 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, 0 )

            END IF

            IF (RORDER) THEN

            CALL CCHK1( 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, 1 )

            END IF

            GO TO 200

*           Test CHEMV, 03, CHBMV, 04, and CHPMV, 05.

  150      IF (CORDER) THEN

           CALL CCHK2( 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, 0 )

           END IF

           IF (RORDER) THEN

           CALL CCHK2( 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, 1 )

           END IF

            GO TO 200

*           Test CTRMV, 06, CTBMV, 07, CTPMV, 08,

*           CTRSV, 09, CTBSV, 10, and CTPSV, 11.

  160      IF (CORDER) THEN

           CALL CCHK3( 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, 

     $			0 )

           END IF

           IF (RORDER) THEN

           CALL CCHK3( 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, 

     $			1 )

           END IF

            GO TO 200

*           Test CGERC, 12, CGERU, 13.

  170      IF (CORDER) THEN

           CALL CCHK4( 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, 0 )

           END IF

           IF (RORDER) THEN

           CALL CCHK4( 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, 1 )

           END IF

            GO TO 200

*           Test CHER, 14, and CHPR, 15.

  180      IF (CORDER) THEN

           CALL CCHK5( 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, 0 )

           END IF

           IF (RORDER) THEN

           CALL CCHK5( 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, 1 )

           END IF

            GO TO 200

*           Test CHER2, 16, and CHPR2, 17.

  190      IF (CORDER) THEN

           CALL CCHK6( 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, 0 )

           END IF

           IF (RORDER) THEN

           CALL CCHK6( 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, 1 )

           END IF

*

  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

*

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( ' 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          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 ',A12, ' NOT RECOGNIZED', /' ******* T',

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

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

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

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

 9982 FORMAT( /' END OF TESTS' )

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

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

*

*     End of CBLAT2.

*

      END

      SUBROUTINE CCHK1( 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, IORDER )

*

*  Tests CGEMV and CGBMV.

*

*  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            ZERO, HALF

      PARAMETER          ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) )

      REAL               RZERO

      PARAMETER          ( RZERO = 0.0 )

*     .. Scalar Arguments ..

      REAL               EPS, THRESH

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

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

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

     $                   YY( NMAX*INCMAX )

      REAL               G( NMAX )

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

*     .. Local Scalars ..

      COMPLEX            ALPHA, ALS, BETA, BLS, TRANSL

      REAL               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*14       CTRANS

      CHARACTER*3        ICH

*     .. Local Arrays ..

      LOGICAL            ISAME( 13 )

*     .. External Functions ..

      LOGICAL            LCE, LCERES

      EXTERNAL           LCE, LCERES

*     .. External Subroutines ..

      EXTERNAL           CCGBMV, CCGEMV, CMAKE, CMVCH

*     .. Intrinsic Functions ..

      INTRINSIC          ABS, MAX, MIN

*     .. Scalars in Common ..

      INTEGER            INFOT, NOUTC

      LOGICAL            OK

*     .. Common blocks ..

      COMMON             /INFOC/INFOT, NOUTC, OK

*     .. Data statements ..

      DATA               ICH/'NTC'/

*     .. Executable Statements ..

      FULL = SNAME( 9: 9 ).EQ.'e'

      BANDED = SNAME( 9: 9 ).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 CMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, AA,

     $                     LDA, KL, KU, RESET, TRANSL )

*

               DO 90 IC = 1, 3

                  TRANS = ICH( IC: IC )

                  IF (TRANS.EQ.'N')THEN

                     CTRANS = '  CblasNoTrans'

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

                     CTRANS = '    CblasTrans'

                  ELSE 

                     CTRANS = 'CblasConjTrans'

                  END IF

                  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 CMAKE( '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 CMAKE( '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,

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

     $                              INCY

                                 IF( REWI )

     $                              REWIND NTRA

                                 CALL CCGEMV( IORDER, TRANS, M, N,

     $                                      ALPHA, AA, LDA, XX, INCX,

     $                                      BETA, YY, INCY )

                              ELSE IF( BANDED )THEN

                                 IF( TRACE )

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

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

     $                              INCX, BETA, INCY

                                 IF( REWI )

     $                              REWIND NTRA

                                 CALL CCGBMV( IORDER, 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.

*

*        IF(TRANS .NE. 'C' .OR. (INCX .GT. 0 .AND. INCY .GT. 0)) THEN 

                              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 ) = LCE( AS, AA, LAA )

                                 ISAME( 6 ) = LDAS.EQ.LDA

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

                                 ISAME( 8 ) = INCXS.EQ.INCX

                                 ISAME( 9 ) = BLS.EQ.BETA

                                 IF( NULL )THEN

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

                                 ELSE

                                    ISAME( 10 ) = LCERES( '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 ) = LCE( AS, AA, LAA )

                                 ISAME( 8 ) = LDAS.EQ.LDA

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

                                 ISAME( 10 ) = INCXS.EQ.INCX

                                 ISAME( 11 ) = BLS.EQ.BETA

                                 IF( NULL )THEN

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

                                 ELSE

                                    ISAME( 12 ) = LCERES( '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 CMVCH( 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

*                          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, CTRANS, M, N, ALPHA, LDA,

     $      INCX, BETA, INCY

      ELSE IF( BANDED )THEN

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

     $      ALPHA, LDA, INCX, BETA, INCY

      END IF

*

  140 CONTINUE

      RETURN

*

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

     $      'S)' )

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

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

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

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

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

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

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

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

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

 9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), '(',

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

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

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

     $      '******' )

*

*     End of CCHK1.

*

      END

      SUBROUTINE CCHK2( 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, IORDER )

*

*  Tests CHEMV, CHBMV and CHPMV.

*

*  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            ZERO, HALF

      PARAMETER          ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) )

      REAL               RZERO

      PARAMETER          ( RZERO = 0.0 )

*     .. Scalar Arguments ..

      REAL               EPS, THRESH

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

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

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

     $                   YY( NMAX*INCMAX )

      REAL               G( NMAX )

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

*     .. Local Scalars ..

      COMPLEX            ALPHA, ALS, BETA, BLS, TRANSL

      REAL               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*14       CUPLO

      CHARACTER*2        ICH

*     .. Local Arrays ..

      LOGICAL            ISAME( 13 )

*     .. External Functions ..

      LOGICAL            LCE, LCERES

      EXTERNAL           LCE, LCERES

*     .. External Subroutines ..

      EXTERNAL           CCHBMV, CCHEMV, CCHPMV, CMAKE, CMVCH

*     .. Intrinsic Functions ..

      INTRINSIC          ABS, MAX

*     .. Scalars in Common ..

      INTEGER            INFOT, NOUTC

      LOGICAL             OK

*     .. Common blocks ..

      COMMON             /INFOC/INFOT, NOUTC, OK

*     .. Data statements ..

      DATA               ICH/'UL'/

*     .. Executable Statements ..

      FULL = SNAME( 9: 9 ).EQ.'e'

      BANDED = SNAME( 9: 9 ).EQ.'b'

      PACKED = SNAME( 9: 9 ).EQ.'p'