      PROGRAM SB2TIM
*
***********************************************************************
*
*  Timing program for the REAL             Level 2 BLAS.
*
*  The program calls a REAL function SECOND with no arguments, which
*  is assumed to return the central-processor time in seconds from
*  some fixed starting-time.
*
*  The program must be driven by a short data file, which specifies
*  values for the matrix dimensions M and N, the bandwidth K, and
*  for the leading array dimension LDA. The data file is read from
*  unit NIN. Results are written to unit NOUT. NIN and NOUT are set
*  to 5 and 6 respectively in a PARAMETER statement, but can easily
*  be changed.
*
*  The first 9 records of the data file are read using list-directed
*  input, the last 16 records are read using the format ( A ). An
*  annotated example of a data file can be obtained by deleting the
*  first 3 characters from the following 27 lines:
*  Data file for timing program for the REAL             Level 2 BLAS
*  5                     Number of values of M (maximum 12)
*  32 64 128 256 512     The values of M
*  5                     Number of values of N (maximum 12)
*  32 64 128 256 512     The values of N
*  2                     Number of values of K (maximum 12)
*  8 32                  The values of K
*  2                     Number of values of INCX = INCY (maximum 4)
*  1 2                   The values of INCX = INCY
*  2                     Number of values of LDA (maximum 12)
*  512 513               The values of LDA
*  SGEMV     T           ('T' or 't' means 'Time this routine')
*  SGBMV     T
*  SSYMV     T
*  SSBMV     T
*  SSPMV     T
*  STRMV     T
*  STBMV     T
*  STPMV     T
*  STRSV     T
*  STBSV     T
*  STPSV     T
*  SGER      T
*  SSYR      T
*  SSPR      T
*  SSYR2     T
*  SSPR2     T
*
*  The maximum value for M and N (NMAX) is defined in a PARAMETER
*  statement as 512. The maximum value for INCX and INCY (INCMAX) is
*  defined in a PARAMETER statement as 32. The maximum value of LDA
*  is defined in a PARAMETER statement as NMAX+32. All three can
*  easily be changed. The maximum value for K is (NMAX-1)/2.
*
*  Each routine is timed for all possible values of the options
*  TRANS and UPLO. Option DIAG is always set to 'N'. All elements
*  of the matrices are initialised to non-zero values. ALPHA and
*  BETA are set to values other than 0, 1, -1. The routines are
*  timed for all combinations of applicable values of M, N, K, LDA
*  and INCX=INCY. Note that this can take a considerable amount of
*  time. It is important that the Level 2 BLAS should perform as well
*  as possible for all shapes and sizes of matrices.
*
***********************************************************************
*
*  -- Written on 28-August-1989.
*     Jeremy Du Croz and Mick Pont, NAG Central Office.
*
*     .. Parameters ..
      INTEGER            NIN, NOUT
      PARAMETER          ( NIN = 5, NOUT = 6 )
      INTEGER            MAXVAL, MXNINC, MXNLDA
      PARAMETER          ( MAXVAL = 12, MXNINC = 4, MXNLDA = 12 )
      INTEGER            NMAX, KMAX, INCMAX, LDAMAX
      PARAMETER          ( NMAX = 512, KMAX = ( NMAX - 1 )/2,
     $                   INCMAX = 32, LDAMAX = NMAX + 32 )
      INTEGER            LA, LX
      PARAMETER          ( LA = NMAX*LDAMAX, LX = NMAX*INCMAX )
      INTEGER            NTRANS, NUPLOS
      PARAMETER          ( NTRANS = 2, NUPLOS = 2 )
      INTEGER            LDRES
      PARAMETER          ( LDRES = MAXVAL )
      INTEGER            NSUBS
      PARAMETER          ( NSUBS = 16 )
*     .. Local Scalars ..
      INTEGER            I, IINC, ILDA, INCX, ISUB, ITA, IUPLO, J, LDA,
     $                   MATCH, NINCS, NKVALS, NLDA, NMVALS, NNVALS
      LOGICAL            IXANDY
      CHARACTER*80       LINE
*     .. Local Arrays ..
      REAL               A( LA ), RESLTS( LDRES, MAXVAL, MXNLDA,
     $                   MXNINC ), X( LX ), Y( LX )
      INTEGER            INCS( MXNINC ), KVALS( MAXVAL ),
     $                   LDAVAL( MXNLDA ), MVALS( MAXVAL ),
     $                   NVALS( MAXVAL )
      LOGICAL            TSTSUB( NSUBS )
      CHARACTER*1        TRANS( NTRANS ), UPLOS( NUPLOS )
      CHARACTER*6        NAMES( NSUBS )
*     .. External Subroutines ..
      EXTERNAL           PRNTAB, PRNTB1, STIM01, STIM02, STIM03, STIM04,
     $                   STIM05, STIM06, STIM07, STIM08, STIM09, STIM10,
     $                   STIM11, STIM12, STIM13, STIM14, STIM15, STIM16
*     .. Intrinsic Functions ..
      INTRINSIC          REAL
*     .. Data statements ..
      DATA               NAMES/'SGEMV ', 'SGBMV ', 'SSYMV ', 'SSBMV ',
     $                   'SSPMV ', 'STRMV ', 'STBMV ', 'STPMV ',
     $                   'STRSV ', 'STBSV ', 'STPSV ', 'SGER  ',
     $                   'SSYR  ', 'SSPR  ', 'SSYR2 ', 'SSPR2 '/
      DATA               TRANS/'N', 'T'/
      DATA               UPLOS/'U', 'L'/
*     .. Executable Statements ..
*
*     Read driving file.
*
      READ( NIN, FMT = * )
      READ( NIN, FMT = * )NMVALS
      IF( NMVALS.GT.MAXVAL )THEN
         WRITE( NOUT, FMT = * )'Too many values of M: NMVALS = ', NMVALS
         STOP
      END IF
      READ( NIN, FMT = * )( MVALS( I ), I = 1, NMVALS )
      DO 10 I = 1, NMVALS
         IF( MVALS( I ).GT.NMAX )THEN
            WRITE( NOUT, FMT = * )'A value of M is too large: value is '
     $         , MVALS( I )
            STOP
         END IF
   10 CONTINUE
      READ( NIN, FMT = * )NNVALS
      IF( NNVALS.GT.MAXVAL )THEN
         WRITE( NOUT, FMT = * )'Too many values of N: NNVALS = ', NNVALS
         STOP
      END IF
      READ( NIN, FMT = * )( NVALS( I ), I = 1, NNVALS )
      DO 20 I = 1, NNVALS
         IF( NVALS( I ).GT.NMAX )THEN
            WRITE( NOUT, FMT = * )'A value of N is too large: value is '
     $         , NVALS( I )
            STOP
         END IF
   20 CONTINUE
      READ( NIN, FMT = * )NKVALS
      IF( NKVALS.GT.MAXVAL )THEN
         WRITE( NOUT, FMT = * )'Too many values of K: NKVALS = ', NKVALS
         STOP
      END IF
      READ( NIN, FMT = * )( KVALS( I ), I = 1, NKVALS )
      DO 30 I = 1, NKVALS
         IF( KVALS( I ).GT.KMAX )THEN
            WRITE( NOUT, FMT = * )'A value of K is too large: value is '
     $         , KVALS( I )
            STOP
         END IF
   30 CONTINUE
      READ( NIN, FMT = * )NINCS
      IF( NINCS.GT.MXNINC )THEN
         WRITE( NOUT, FMT = * )'Too many values of INCX: NINCS = ',
     $      NINCS
         STOP
      END IF
      READ( NIN, FMT = * )( INCS( I ), I = 1, NINCS )
      DO 40 I = 1, NINCS
         IF( INCS( I ).GT.INCMAX )THEN
            WRITE( NOUT, FMT = * )
     $         'A value of INCX is too large: value is ', INCS( I )
            STOP
         END IF
   40 CONTINUE
      READ( NIN, FMT = * )NLDA
      IF( NLDA.GT.MXNLDA )THEN
         WRITE( NOUT, FMT = * )'Too many values of LDA: NLDA = ', NLDA
         STOP
      END IF
      READ( NIN, FMT = * )( LDAVAL( I ), I = 1, NLDA )
      DO 50 I = 1, NLDA
         IF( LDAVAL( I ).GT.LDAMAX )THEN
            WRITE( NOUT, FMT = * )
     $         'A value of LDA is too large: value is ', LDAVAL( I )
            STOP
         END IF
   50 CONTINUE
*
*     Decide which routines are to be timed.
*
   60 READ( NIN, FMT = '(A)', END = 90 )LINE
      MATCH = 0
      DO 70 I = 1, NSUBS
         IF( NAMES( I ).EQ.LINE( 1: 6 ) )
     $      MATCH = I
   70 CONTINUE
      IF( MATCH.EQ.0 )THEN
         WRITE( NOUT, FMT = * )'Unknown subroutine name: ''',
     $      LINE( 1: 6 ), ''''
         STOP
      END IF
      I = 7
   80 IF( LINE( I: I ).EQ.' '.AND.I.LT.80 )THEN
         I = I + 1
         GO TO 80
      END IF
*
*     We will time routine if first non-blank character is 'T' or 't'.
*
      TSTSUB( MATCH ) = LINE( I: I ).EQ.'T'.OR.LINE( I: I ).EQ.'t'
      GO TO 60
   90 CONTINUE
*
*     Time each routine
*
      DO 630 ISUB = 1, NSUBS
         IF( TSTSUB( ISUB ) )THEN
*
*           Generate data
*
            DO 100 I = 1, LA
               A( I ) = 1.0E0 + REAL( I )/( LA + 1 )
  100       CONTINUE
            DO 110 I = 1, LX
               X( I ) = I*1.013E0
               Y( I ) = I*1.013E0
  110       CONTINUE
*
*           Print header.
*
            WRITE( NOUT, FMT = 9999 )NAMES( ISUB )
            IXANDY = ISUB.LE.5.OR.ISUB.EQ.12.OR.ISUB.EQ.15.OR.ISUB.EQ.16
            IF( NAMES( ISUB )( 3: 3 ).NE.'P' )THEN
               IF( NLDA*NINCS.EQ.1 )THEN
                  IF( IXANDY )THEN
                     WRITE( NOUT, FMT = 9998 )LDAVAL( 1 ), INCS( 1 )
                  ELSE
                     WRITE( NOUT, FMT = 9997 )LDAVAL( 1 ), INCS( 1 )
                  END IF
               ELSE
                  DO 130 I = 1, NLDA
                     DO 120 J = 1, NINCS
                        IF( IXANDY )THEN
                           WRITE( NOUT, FMT = 9994 )( I - 1 )*NINCS + J,
     $                        LDAVAL( I ), INCS( J )
                        ELSE
                           WRITE( NOUT, FMT = 9993 )( I - 1 )*NINCS + J,
     $                        LDAVAL( I ), INCS( J )
                        END IF
  120                CONTINUE
  130             CONTINUE
               END IF
            ELSE
               IF( NINCS.EQ.1 )THEN
                  IF( IXANDY )THEN
                     WRITE( NOUT, FMT = 9996 )INCS( 1 )
                  ELSE
                     WRITE( NOUT, FMT = 9995 )INCS( 1 )
                  END IF
               ELSE
                  DO 140 J = 1, NINCS
                     IF( IXANDY )THEN
                        WRITE( NOUT, FMT = 9992 )J, INCS( J )
                     ELSE
                        WRITE( NOUT, FMT = 9991 )J, INCS( J )
                     END IF
  140             CONTINUE
               END IF
            END IF
*
            IF( NAMES( ISUB ).EQ.'SGEMV ' )THEN
               DO 170 ITA = 1, NTRANS
                  DO 160 ILDA = 1, NLDA
                     LDA = LDAVAL( ILDA )
                     DO 150 IINC = 1, NINCS
                        INCX = INCS( IINC )
                        CALL STIM01( TRANS( ITA ), NMAX, MVALS, NMVALS,
     $                               NVALS, NNVALS, A, LDA, INCX, X, Y,
     $                               LDRES, RESLTS( 1, 1, ILDA, IINC ) )
  150                CONTINUE
  160             CONTINUE
                  WRITE( NOUT, FMT = 9990 )TRANS( ITA )
                  CALL PRNTAB( 'M', 'N', MVALS, NMVALS, NVALS, NNVALS,
     $                         NINCS, NLDA, RESLTS, LDRES, MAXVAL,
     $                         MAXVAL, NOUT )
  170          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'SGBMV ' )THEN
               DO 200 ITA = 1, NTRANS
                  DO 190 ILDA = 1, NLDA
                     LDA = LDAVAL( ILDA )
                     DO 180 IINC = 1, NINCS
                        INCX = INCS( IINC )
                        CALL STIM02( TRANS( ITA ), NMAX, KVALS, NKVALS,
     $                               NVALS, NNVALS, A, LDA, INCX, X, Y,
     $                               LDRES, RESLTS( 1, 1, ILDA, IINC ) )
  180                CONTINUE
  190             CONTINUE
                  WRITE( NOUT, FMT = 9989 )TRANS( ITA )
                  CALL PRNTAB( 'K', 'N', KVALS, NKVALS, NVALS, NNVALS,
     $                         NINCS, NLDA, RESLTS, LDRES, MAXVAL,
     $                         MAXVAL, NOUT )
  200          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'SSYMV ' )THEN
               DO 230 IUPLO = 1, NUPLOS
                  DO 220 ILDA = 1, NLDA
                     LDA = LDAVAL( ILDA )
                     DO 210 IINC = 1, NINCS
                        INCX = INCS( IINC )
                        CALL STIM03( UPLOS( IUPLO ), NMAX, NVALS,
     $                               NNVALS, A, LDA, INCX, X, Y, LDRES,
     $                               RESLTS( 1, 1, ILDA, IINC ) )
  210                CONTINUE
  220             CONTINUE
                  WRITE( NOUT, FMT = 9988 )UPLOS( IUPLO )
                  CALL PRNTB1( 'N', NVALS, NNVALS, NINCS, NLDA, RESLTS,
     $                         LDRES, MAXVAL, MAXVAL, NOUT )
  230          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'SSBMV ' )THEN
               DO 260 IUPLO = 1, NUPLOS
                  DO 250 ILDA = 1, NLDA
                     LDA = LDAVAL( ILDA )
                     DO 240 IINC = 1, NINCS
                        INCX = INCS( IINC )
                        CALL STIM04( UPLOS( IUPLO ), NMAX, KVALS,
     $                               NKVALS, NVALS, NNVALS, A, LDA,
     $                               INCX, X, Y, LDRES,
     $                               RESLTS( 1, 1, ILDA, IINC ) )
  240                CONTINUE
  250             CONTINUE
                  WRITE( NOUT, FMT = 9987 )UPLOS( IUPLO )
                  CALL PRNTAB( 'K', 'N', KVALS, NKVALS, NVALS, NNVALS,
     $                         NINCS, NLDA, RESLTS, LDRES, MAXVAL,
     $                         MAXVAL, NOUT )
  260          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'SSPMV ' )THEN
               DO 280 IUPLO = 1, NUPLOS
                  ILDA = 1
                  LDA = LDAVAL( ILDA )
                  DO 270 IINC = 1, NINCS
                     INCX = INCS( IINC )
                     CALL STIM05( UPLOS( IUPLO ), NMAX, NVALS, NNVALS,
     $                            A, LDA, INCX, X, Y, LDRES,
     $                            RESLTS( 1, 1, ILDA, IINC ) )
  270             CONTINUE
                  WRITE( NOUT, FMT = 9986 )UPLOS( IUPLO )
                  CALL PRNTB1( 'N', NVALS, NNVALS, NINCS, 1, RESLTS,
     $                         LDRES, MAXVAL, MAXVAL, NOUT )
  280          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'STRMV ' )THEN
               DO 320 IUPLO = 1, NUPLOS
                  DO 310 ITA = 1, NTRANS
                     DO 300 ILDA = 1, NLDA
                        LDA = LDAVAL( ILDA )
                        DO 290 IINC = 1, NINCS
                           INCX = INCS( IINC )
                           CALL STIM06( UPLOS( IUPLO ), TRANS( ITA ),
     $                                  NMAX, NVALS, NNVALS, A, LDA,
     $                                  INCX, X, LDRES,
     $                                  RESLTS( 1, 1, ILDA, IINC ) )
  290                   CONTINUE
  300                CONTINUE
                     WRITE( NOUT, FMT = 9985 )UPLOS( IUPLO ),
     $                  TRANS( ITA )
                     CALL PRNTB1( 'N', NVALS, NNVALS, NINCS, NLDA,
     $                            RESLTS, LDRES, MAXVAL, MAXVAL, NOUT )
  310             CONTINUE
  320          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'STBMV ' )THEN
               DO 360 IUPLO = 1, NUPLOS
                  DO 350 ITA = 1, NTRANS
                     DO 340 ILDA = 1, NLDA
                        LDA = LDAVAL( ILDA )
                        DO 330 IINC = 1, NINCS
                           INCX = INCS( IINC )
                           CALL STIM07( UPLOS( IUPLO ), TRANS( ITA ),
     $                                  NMAX, KVALS, NKVALS, NVALS,
     $                                  NNVALS, A, LDA, INCX, X, LDRES,
     $                                  RESLTS( 1, 1, ILDA, IINC ) )
  330                   CONTINUE
  340                CONTINUE
                     WRITE( NOUT, FMT = 9984 )UPLOS( IUPLO ),
     $                  TRANS( ITA )
                     CALL PRNTAB( 'K', 'N', KVALS, NKVALS, NVALS,
     $                            NNVALS, NINCS, NLDA, RESLTS, LDRES,
     $                            MAXVAL, MAXVAL, NOUT )
  350             CONTINUE
  360          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'STPMV ' )THEN
               DO 390 IUPLO = 1, NUPLOS
                  DO 380 ITA = 1, NTRANS
                     ILDA = 1
                     LDA = LDAVAL( ILDA )
                     DO 370 IINC = 1, NINCS
                        INCX = INCS( IINC )
                        CALL STIM08( UPLOS( IUPLO ), TRANS( ITA ), NMAX,
     $                               NVALS, NNVALS, A, LDA, INCX, X,
     $                               LDRES, RESLTS( 1, 1, ILDA, IINC ) )
  370                CONTINUE
                     WRITE( NOUT, FMT = 9983 )UPLOS( IUPLO ),
     $                  TRANS( ITA )
                     CALL PRNTB1( 'N', NVALS, NNVALS, NINCS, 1, RESLTS,
     $                            LDRES, MAXVAL, MAXVAL, NOUT )
  380             CONTINUE
  390          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'STRSV ' )THEN
               DO 430 IUPLO = 1, NUPLOS
                  DO 420 ITA = 1, NTRANS
                     DO 410 ILDA = 1, NLDA
                        LDA = LDAVAL( ILDA )
                        DO 400 IINC = 1, NINCS
                           INCX = INCS( IINC )
                           CALL STIM09( UPLOS( IUPLO ), TRANS( ITA ),
     $                                  NMAX, NVALS, NNVALS, A, LDA,
     $                                  INCX, X, LDRES,
     $                                  RESLTS( 1, 1, ILDA, IINC ) )
  400                   CONTINUE
  410                CONTINUE
                     WRITE( NOUT, FMT = 9982 )UPLOS( IUPLO ),
     $                  TRANS( ITA )
                     CALL PRNTB1( 'N', NVALS, NNVALS, NINCS, NLDA,
     $                            RESLTS, LDRES, MAXVAL, MAXVAL, NOUT )
  420             CONTINUE
  430          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'STBSV ' )THEN
               DO 470 IUPLO = 1, NUPLOS
                  DO 460 ITA = 1, NTRANS
                     DO 450 ILDA = 1, NLDA
                        LDA = LDAVAL( ILDA )
                        DO 440 IINC = 1, NINCS
                           INCX = INCS( IINC )
                           CALL STIM10( UPLOS( IUPLO ), TRANS( ITA ),
     $                                  NMAX, KVALS, NKVALS, NVALS,
     $                                  NNVALS, A, LDA, INCX, X, LDRES,
     $                                  RESLTS( 1, 1, ILDA, IINC ) )
  440                   CONTINUE
  450                CONTINUE
                     WRITE( NOUT, FMT = 9981 )UPLOS( IUPLO ),
     $                  TRANS( ITA )
                     CALL PRNTAB( 'K', 'N', KVALS, NKVALS, NVALS,
     $                            NNVALS, NINCS, NLDA, RESLTS, LDRES,
     $                            MAXVAL, MAXVAL, NOUT )
  460             CONTINUE
  470          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'STPSV ' )THEN
               DO 500 IUPLO = 1, NUPLOS
                  DO 490 ITA = 1, NTRANS
                     ILDA = 1
                     LDA = LDAVAL( ILDA )
                     DO 480 IINC = 1, NINCS
                        INCX = INCS( IINC )
                        CALL STIM11( UPLOS( IUPLO ), TRANS( ITA ), NMAX,
     $                               NVALS, NNVALS, A, LDA, INCX, X,
     $                               LDRES, RESLTS( 1, 1, ILDA, IINC ) )
  480                CONTINUE
                     WRITE( NOUT, FMT = 9980 )UPLOS( IUPLO ),
     $                  TRANS( ITA )
                     CALL PRNTB1( 'N', NVALS, NNVALS, NINCS, 1, RESLTS,
     $                            LDRES, MAXVAL, MAXVAL, NOUT )
  490             CONTINUE
  500          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'SGER  ' )THEN
               DO 520 ILDA = 1, NLDA
                  LDA = LDAVAL( ILDA )
                  DO 510 IINC = 1, NINCS
                     INCX = INCS( IINC )
                     CALL STIM12( NMAX, MVALS, NMVALS, NVALS, NNVALS, A,
     $                            LDA, INCX, X, Y, LDRES,
     $                            RESLTS( 1, 1, ILDA, IINC ) )
  510             CONTINUE
  520          CONTINUE
               WRITE( NOUT, FMT = 9979 )
               CALL PRNTAB( 'M', 'N', MVALS, NMVALS, NVALS, NNVALS,
     $                      NINCS, NLDA, RESLTS, LDRES, MAXVAL, MAXVAL,
     $                      NOUT )
            ELSE IF( NAMES( ISUB ).EQ.'SSYR  ' )THEN
               DO 550 IUPLO = 1, NUPLOS
                  DO 540 ILDA = 1, NLDA
                     LDA = LDAVAL( ILDA )
                     DO 530 IINC = 1, NINCS
                        INCX = INCS( IINC )
                        CALL STIM13( UPLOS( IUPLO ), NMAX, NVALS,
     $                               NNVALS, A, LDA, INCX, X, LDRES,
     $                               RESLTS( 1, 1, ILDA, IINC ) )
  530                CONTINUE
  540             CONTINUE
                  WRITE( NOUT, FMT = 9978 )UPLOS( IUPLO )
                  CALL PRNTB1( 'N', NVALS, NNVALS, NINCS, NLDA, RESLTS,
     $                         LDRES, MAXVAL, MAXVAL, NOUT )
  550          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'SSPR  ' )THEN
               DO 570 IUPLO = 1, NUPLOS
                  ILDA = 1
                  LDA = LDAVAL( ILDA )
                  DO 560 IINC = 1, NINCS
                     INCX = INCS( IINC )
                     CALL STIM14( UPLOS( IUPLO ), NMAX, NVALS, NNVALS,
     $                            A, LDA, INCX, X, LDRES,
     $                            RESLTS( 1, 1, ILDA, IINC ) )
  560             CONTINUE
                  WRITE( NOUT, FMT = 9977 )UPLOS( IUPLO )
                  CALL PRNTB1( 'N', NVALS, NNVALS, NINCS, 1, RESLTS,
     $                         LDRES, MAXVAL, MAXVAL, NOUT )
  570          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'SSYR2 ' )THEN
               DO 600 IUPLO = 1, NUPLOS
                  DO 590 ILDA = 1, NLDA
                     LDA = LDAVAL( ILDA )
                     DO 580 IINC = 1, NINCS
                        INCX = INCS( IINC )
                        CALL STIM15( UPLOS( IUPLO ), NMAX, NVALS,
     $                               NNVALS, A, LDA, INCX, X, Y, LDRES,
     $                               RESLTS( 1, 1, ILDA, IINC ) )
  580                CONTINUE
  590             CONTINUE
                  WRITE( NOUT, FMT = 9976 )UPLOS( IUPLO )
                  CALL PRNTB1( 'N', NVALS, NNVALS, NINCS, NLDA, RESLTS,
     $                         LDRES, MAXVAL, MAXVAL, NOUT )
  600          CONTINUE
            ELSE IF( NAMES( ISUB ).EQ.'SSPR2 ' )THEN
               DO 620 IUPLO = 1, NUPLOS
                  ILDA = 1
                  LDA = LDAVAL( ILDA )
                  DO 610 IINC = 1, NINCS
                     INCX = INCS( IINC )
                     CALL STIM16( UPLOS( IUPLO ), NMAX, NVALS, NNVALS,
     $                            A, LDA, INCX, X, Y, LDRES,
     $                            RESLTS( 1, 1, ILDA, IINC ) )
  610             CONTINUE
                  WRITE( NOUT, FMT = 9975 )UPLOS( IUPLO )
                  CALL PRNTB1( 'N', NVALS, NNVALS, NINCS, 1, RESLTS,
     $                         LDRES, MAXVAL, MAXVAL, NOUT )
  620          CONTINUE
            END IF
            WRITE( NOUT, FMT = 9974 )
         END IF
  630 CONTINUE
*
 9999 FORMAT( '1*** Speed of ', A, ' in megaflops ***' )
 9998 FORMAT( 5X, 'with LDA = ', I5, ' and INCX = INCY = ', I5 )
 9997 FORMAT( 5X, 'with LDA = ', I5, ' and INCX = ', I5 )
 9996 FORMAT( 5X, 'with INCX = INCY = ', I5 )
 9995 FORMAT( 5X, 'with INCX = ', I5 )
 9994 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5,
     $      ' and INCX = INCY = ', I5 )
 9993 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5, ' and INCX = ', I5 )
 9992 FORMAT( 5X, 'line ', I2, ' with INCX = INCY = ', I5 )
 9991 FORMAT( 5X, 'line ', I2, ' with INCX = ', I5 )
 9990 FORMAT( /1X, 'SGEMV with TRANS = ''', A, '''', / )
 9989 FORMAT( /1X, 'SGBMV with TRANS = ''', A, ''', M = N and KL = KU ',
     $      '= K', / )
 9988 FORMAT( /1X, 'SSYMV with UPLO = ''', A, '''', / )
 9987 FORMAT( /1X, 'SSBMV with UPLO = ''', A, '''', / )
 9986 FORMAT( /1X, 'SSPMV with UPLO = ''', A, '''', / )
 9985 FORMAT( /1X, 'STRMV with UPLO = ''', A, ''', TRANS = ''', A, '''',
     $      / )
 9984 FORMAT( /1X, 'STBMV with UPLO = ''', A, ''', TRANS = ''', A, '''',
     $      / )
 9983 FORMAT( /1X, 'STPMV with UPLO = ''', A, ''', TRANS = ''', A, '''',
     $      / )
 9982 FORMAT( /1X, 'STRSV with UPLO = ''', A, ''', TRANS = ''', A, '''',
     $      / )
 9981 FORMAT( /1X, 'STBSV with UPLO = ''', A, ''', TRANS = ''', A, '''',
     $      / )
 9980 FORMAT( /1X, 'STPSV with UPLO = ''', A, ''', TRANS = ''', A, '''',
     $      / )
 9979 FORMAT( /1X, 'SGER', / )
 9978 FORMAT( /1X, 'SSYR with UPLO = ''', A, '''', / )
 9977 FORMAT( /1X, 'SSPR with UPLO = ''', A, '''', / )
 9976 FORMAT( /1X, 'SSYR2 with UPLO = ''', A, '''', / )
 9975 FORMAT( /1X, 'SSPR2 with UPLO = ''', A, '''', / )
 9974 FORMAT( ///// )
      END
*
      SUBROUTINE PRNTAB( LAB1, LAB2, M, LENM, N, LENN, NINCS, NLDA,
     $                   RESLTS, LDRES, SECRES, THDRES, NOUT )
*     .. Scalar Arguments ..
      INTEGER            LDRES, LENM, LENN, NINCS, NLDA, NOUT, SECRES,
     $                   THDRES
      CHARACTER*1        LAB1, LAB2
*     .. Array Arguments ..
      REAL               RESLTS( LDRES, SECRES, THDRES, NINCS )
      INTEGER            M( LENM ), N( LENN )
*     .. Local Scalars ..
      INTEGER            I, J, K, L
*     .. Executable Statements ..
      WRITE( NOUT, FMT = 9999 )LAB2, ( N( I ), I = 1, LENN )
      WRITE( NOUT, FMT = 9998 )LAB1
      DO 30 I = 1, LENM
         WRITE( NOUT, FMT = 9997 )M( I ),
     $      ( RESLTS( I, J, 1, 1 ), J = 1, LENN )
         DO 20 K = 1, NLDA
            DO 10 L = 1, NINCS
               IF( K*L.GT.1 )
     $            WRITE( NOUT, FMT = 9996 )( RESLTS( I, J, K, L ),
     $            J = 1, LENN )
   10       CONTINUE
   20    CONTINUE
         IF( NLDA*NINCS.GT.1 )
     $      WRITE( NOUT, FMT = * )
   30 CONTINUE
      RETURN
*
 9999 FORMAT( 7X, A, I6, 11I9 )
 9998 FORMAT( 4X, A )
 9997 FORMAT( 1X, I4, 12F9.2 )
 9996 FORMAT( 5X, 12F9.2 )
      END
*
      SUBROUTINE PRNTB1( LAB1, N, LENN, NINCS, NLDA, RESLTS, LDRES,
     $                   SECRES, THDRES, NOUT )
*     .. Scalar Arguments ..
      INTEGER            LDRES, LENN, NINCS, NLDA, NOUT, SECRES, THDRES
      CHARACTER*1        LAB1
*     .. Array Arguments ..
      REAL               RESLTS( LDRES, SECRES, THDRES, NINCS )
      INTEGER            N( LENN )
*     .. Local Scalars ..
      INTEGER            I, J, K, L
*     .. Executable Statements ..
      WRITE( NOUT, FMT = 9999 )LAB1, ( N( I ), I = 1, LENN )
      WRITE( NOUT, FMT = * )
      DO 20 K = 1, NLDA
         DO 10 L = 1, NINCS
            WRITE( NOUT, FMT = 9998 )( RESLTS( 1, J, K, L ), J = 1,
     $         LENN )
   10    CONTINUE
   20 CONTINUE
      WRITE( NOUT, FMT = * )
      RETURN
*
 9999 FORMAT( 7X, A, I6, 11I9 )
 9998 FORMAT( 5X, 12F9.2 )
      END
*
      SUBROUTINE STIM01( TRANS, NMAX, MVALS, NMVALS, NVALS, NNVALS, A,
     $                   LDA, INCX, X, Y, LDRES, RESLTS )
*     Times SGEMV.
*     .. Parameters ..
      REAL               ALPHA, BETA
      PARAMETER          ( ALPHA = -0.9E0, BETA = 1.1E0 )
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, LDRES, NMAX, NMVALS, NNVALS
      CHARACTER*1        TRANS
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX ), Y( NMAX*INCX )
      INTEGER            MVALS( NMVALS ), NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, IMVAL, INVAL, M, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           SGEMV
*     .. Executable Statements ..
      DO 30 IMVAL = 1, NMVALS
         M = MVALS( IMVAL )
         DO 20 INVAL = 1, NNVALS
            N = NVALS( INVAL )
*           Re-initialise Y each time to avoid overflow.
            DO 10 I = 1, N*INCX
               Y( I ) = I*1.013E0
   10       CONTINUE
            S0 = SECOND( )
            S1 = SECOND( )
            CALL SGEMV( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y,
     $                  INCX )
            S2 = SECOND( )
            TIME = ( S2 - S1 ) - ( S1 - S0 )
            NOP = 2*M*N + 2*M
            IF( TIME.LE.0.0E0 )THEN
               RESLTS( IMVAL, INVAL ) = 0.0E0
            ELSE
               RESLTS( IMVAL, INVAL ) = NOP/( 1.0E6*TIME )
            END IF
   20    CONTINUE
   30 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM02( TRANS, NMAX, KVALS, NKVALS, NVALS, NNVALS, A,
     $                   LDA, INCX, X, Y, LDRES, RESLTS )
*     Times SGBMV.
*     .. Parameters ..
      REAL               ALPHA, BETA
      PARAMETER          ( ALPHA = -0.9E0, BETA = 1.1E0 )
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, LDRES, NKVALS, NMAX, NNVALS
      CHARACTER*1        TRANS
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX ), Y( NMAX*INCX )
      INTEGER            KVALS( NKVALS ), NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, IKVAL, INVAL, K, K1, M, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           SGBMV
*     .. Intrinsic Functions ..
      INTRINSIC          MIN
*     .. Executable Statements ..
      DO 30 IKVAL = 1, NKVALS
         K = KVALS( IKVAL )
         DO 20 INVAL = 1, NNVALS
            N = NVALS( INVAL )
            M = N
*           Re-initialise Y each time to avoid overflow.
            DO 10 I = 1, N*INCX
               Y( I ) = I*1.013E0
   10       CONTINUE
            S0 = SECOND( )
            S1 = SECOND( )
            CALL SGBMV( TRANS, M, N, K, K, ALPHA, A, LDA, X, INCX, BETA,
     $                  Y, INCX )
            S2 = SECOND( )
            TIME = ( S2 - S1 ) - ( S1 - S0 )
            K1 = MIN( K, N )
            NOP = 2*( ( 2*K1 + 1 )*N - K1*( K1 + 1 ) ) + 2*N
            IF( TIME.LE.0.0E0 )THEN
               RESLTS( IKVAL, INVAL ) = 0.0E0
            ELSE
               RESLTS( IKVAL, INVAL ) = NOP/( 1.0E6*TIME )
            END IF
   20    CONTINUE
   30 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM03( UPLO, NMAX, NVALS, NNVALS, A, LDA, INCX, X, Y,
     $                   LDRES, RESLTS )
*     Times SSYMV.
*     .. Parameters ..
      REAL               ALPHA, BETA
      PARAMETER          ( ALPHA = -0.9E0, BETA = 1.1E0 )
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO
      INTEGER            INCX, LDA, LDRES, NMAX, NNVALS
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX ), Y( NMAX*INCX )
      INTEGER            NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, INVAL, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           SSYMV
*     .. Executable Statements ..
      DO 20 INVAL = 1, NNVALS
         N = NVALS( INVAL )
*           Re-initialise Y each time to avoid overflow.
         DO 10 I = 1, N*INCX
            Y( I ) = I*1.013E0
   10    CONTINUE
         S0 = SECOND( )
         S1 = SECOND( )
         CALL SSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCX )
         S2 = SECOND( )
         TIME = ( S2 - S1 ) - ( S1 - S0 )
         NOP = 2*N*N + 2*N
         IF( TIME.LE.0.0E0 )THEN
            RESLTS( 1, INVAL ) = 0.0E0
         ELSE
            RESLTS( 1, INVAL ) = NOP/( 1.0E6*TIME )
         END IF
   20 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM04( UPLO, NMAX, KVALS, NKVALS, NVALS, NNVALS, A,
     $                   LDA, INCX, X, Y, LDRES, RESLTS )
*     Times SSBMV.
*     .. Parameters ..
      REAL               ALPHA, BETA
      PARAMETER          ( ALPHA = -0.9E0, BETA = 1.1E0 )
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO
      INTEGER            INCX, LDA, LDRES, NKVALS, NMAX, NNVALS
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX ), Y( NMAX*INCX )
      INTEGER            KVALS( NKVALS ), NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, IKVAL, INVAL, K, K1, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           SSBMV
*     .. Intrinsic Functions ..
      INTRINSIC          MIN
*     .. Executable Statements ..
      DO 30 IKVAL = 1, NKVALS
         K = KVALS( IKVAL )
         DO 20 INVAL = 1, NNVALS
            N = NVALS( INVAL )
*           Re-initialise Y each time to avoid overflow.
            DO 10 I = 1, N*INCX
               Y( I ) = I*1.013E0
   10       CONTINUE
            S0 = SECOND( )
            S1 = SECOND( )
            CALL SSBMV( UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y,
     $                  INCX )
            S2 = SECOND( )
            TIME = ( S2 - S1 ) - ( S1 - S0 )
            K1 = MIN( K, N )
            NOP = 2*( ( 2*K1 + 1 )*N - K1*( K1 + 1 ) ) + 2*N
            IF( TIME.LE.0.0E0 )THEN
               RESLTS( IKVAL, INVAL ) = 0.0E0
            ELSE
               RESLTS( IKVAL, INVAL ) = NOP/( 1.0E6*TIME )
            END IF
   20    CONTINUE
   30 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM05( UPLO, NMAX, NVALS, NNVALS, A, LDA, INCX, X, Y,
     $                   LDRES, RESLTS )
*     Times SSPMV.
*     .. Parameters ..
      REAL               ALPHA, BETA
      PARAMETER          ( ALPHA = -0.9E0, BETA = 1.1E0 )
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO
      INTEGER            INCX, LDA, LDRES, NMAX, NNVALS
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX ), Y( NMAX*INCX )
      INTEGER            NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, INVAL, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           SSPMV
*     .. Executable Statements ..
      DO 20 INVAL = 1, NNVALS
         N = NVALS( INVAL )
*           Re-initialise Y each time to avoid overflow.
         DO 10 I = 1, N*INCX
            Y( I ) = I*1.013E0
   10    CONTINUE
         S0 = SECOND( )
         S1 = SECOND( )
         CALL SSPMV( UPLO, N, ALPHA, A, X, INCX, BETA, Y, INCX )
         S2 = SECOND( )
         TIME = ( S2 - S1 ) - ( S1 - S0 )
         NOP = 2*N*N + 2*N
         IF( TIME.LE.0.0E0 )THEN
            RESLTS( 1, INVAL ) = 0.0E0
         ELSE
            RESLTS( 1, INVAL ) = NOP/( 1.0E6*TIME )
         END IF
   20 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM06( UPLO, TRANS, NMAX, NVALS, NNVALS, A, LDA, INCX,
     $                   X, LDRES, RESLTS )
*     Times STRMV.
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, LDRES, NMAX, NNVALS
      CHARACTER*1        TRANS, UPLO
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX )
      INTEGER            NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, INVAL, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           STRMV
*     .. Executable Statements ..
      DO 20 INVAL = 1, NNVALS
         N = NVALS( INVAL )
*           Re-initialise X each time to avoid overflow.
         DO 10 I = 1, N*INCX
            X( I ) = I*1.013E0
   10    CONTINUE
         S0 = SECOND( )
         S1 = SECOND( )
         CALL STRMV( UPLO, TRANS, 'N', N, A, LDA, X, INCX )
         S2 = SECOND( )
         TIME = ( S2 - S1 ) - ( S1 - S0 )
         NOP = N*N
         IF( TIME.LE.0.0E0 )THEN
            RESLTS( 1, INVAL ) = 0.0E0
         ELSE
            RESLTS( 1, INVAL ) = NOP/( 1.0E6*TIME )
         END IF
   20 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM07( UPLO, TRANS, NMAX, KVALS, NKVALS, NVALS,
     $                   NNVALS, A, LDA, INCX, X, LDRES, RESLTS )
*     Times STBMV.
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, LDRES, NKVALS, NMAX, NNVALS
      CHARACTER*1        TRANS, UPLO
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX )
      INTEGER            KVALS( NKVALS ), NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, IKVAL, INVAL, K, K1, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           STBMV
*     .. Intrinsic Functions ..
      INTRINSIC          MIN
*     .. Executable Statements ..
      DO 30 IKVAL = 1, NKVALS
         K = KVALS( IKVAL )
         DO 20 INVAL = 1, NNVALS
            N = NVALS( INVAL )
*           Re-initialise X each time to avoid overflow.
            DO 10 I = 1, N*INCX
               X( I ) = I*1.013E0
   10       CONTINUE
            S0 = SECOND( )
            S1 = SECOND( )
            CALL STBMV( UPLO, TRANS, 'N', N, K, A, LDA, X, INCX )
            S2 = SECOND( )
            TIME = ( S2 - S1 ) - ( S1 - S0 )
            K1 = MIN( K, N )
            NOP = ( 2*N*K1 - K1*( K1 + 1 ) ) + N
            IF( TIME.LE.0.0E0 )THEN
               RESLTS( IKVAL, INVAL ) = 0.0E0
            ELSE
               RESLTS( IKVAL, INVAL ) = NOP/( 1.0E6*TIME )
            END IF
   20    CONTINUE
   30 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM08( UPLO, TRANS, NMAX, NVALS, NNVALS, A, LDA, INCX,
     $                   X, LDRES, RESLTS )
*     Times STPMV.
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, LDRES, NMAX, NNVALS
      CHARACTER*1        TRANS, UPLO
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX )
      INTEGER            NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, INVAL, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           STPMV
*     .. Executable Statements ..
      DO 20 INVAL = 1, NNVALS
         N = NVALS( INVAL )
*           Re-initialise X each time to avoid overflow.
         DO 10 I = 1, N*INCX
            X( I ) = I*1.013E0
   10    CONTINUE
         S0 = SECOND( )
         S1 = SECOND( )
         CALL STPMV( UPLO, TRANS, 'N', N, A, X, INCX )
         S2 = SECOND( )
         TIME = ( S2 - S1 ) - ( S1 - S0 )
         NOP = N*N
         IF( TIME.LE.0.0E0 )THEN
            RESLTS( 1, INVAL ) = 0.0E0
         ELSE
            RESLTS( 1, INVAL ) = NOP/( 1.0E6*TIME )
         END IF
   20 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM09( UPLO, TRANS, NMAX, NVALS, NNVALS, A, LDA, INCX,
     $                   X, LDRES, RESLTS )
*     Times STRSV.
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, LDRES, NMAX, NNVALS
      CHARACTER*1        TRANS, UPLO
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX )
      INTEGER            NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, INVAL, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           STRSV
*     .. Executable Statements ..
      DO 20 INVAL = 1, NNVALS
         N = NVALS( INVAL )
*           Re-initialise X each time to avoid overflow.
         DO 10 I = 1, N*INCX
            X( I ) = I*1.013E0
   10    CONTINUE
         S0 = SECOND( )
         S1 = SECOND( )
         CALL STRSV( UPLO, TRANS, 'N', N, A, LDA, X, INCX )
         S2 = SECOND( )
         TIME = ( S2 - S1 ) - ( S1 - S0 )
         NOP = N*N
         IF( TIME.LE.0.0E0 )THEN
            RESLTS( 1, INVAL ) = 0.0E0
         ELSE
            RESLTS( 1, INVAL ) = NOP/( 1.0E6*TIME )
         END IF
   20 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM10( UPLO, TRANS, NMAX, KVALS, NKVALS, NVALS,
     $                   NNVALS, A, LDA, INCX, X, LDRES, RESLTS )
*     Times STBSV.
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, LDRES, NKVALS, NMAX, NNVALS
      CHARACTER*1        TRANS, UPLO
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX )
      INTEGER            KVALS( NKVALS ), NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, IKVAL, INVAL, K, K1, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           STBSV
*     .. Intrinsic Functions ..
      INTRINSIC          MIN
*     .. Executable Statements ..
      DO 30 IKVAL = 1, NKVALS
         K = KVALS( IKVAL )
         DO 20 INVAL = 1, NNVALS
            N = NVALS( INVAL )
*           Re-initialise X each time to avoid overflow.
            DO 10 I = 1, N*INCX
               X( I ) = I*1.013E0
   10       CONTINUE
            S0 = SECOND( )
            S1 = SECOND( )
            CALL STBSV( UPLO, TRANS, 'N', N, K, A, LDA, X, INCX )
            S2 = SECOND( )
            TIME = ( S2 - S1 ) - ( S1 - S0 )
            K1 = MIN( K, N )
            NOP = ( 2*N*K1 - K1*( K1 + 1 ) ) + N
            IF( TIME.LE.0.0E0 )THEN
               RESLTS( IKVAL, INVAL ) = 0.0E0
            ELSE
               RESLTS( IKVAL, INVAL ) = NOP/( 1.0E6*TIME )
            END IF
   20    CONTINUE
   30 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM11( UPLO, TRANS, NMAX, NVALS, NNVALS, A, LDA, INCX,
     $                   X, LDRES, RESLTS )
*     Times STPSV.
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, LDRES, NMAX, NNVALS
      CHARACTER*1        TRANS, UPLO
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX )
      INTEGER            NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, INVAL, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           STPSV
*     .. Executable Statements ..
      DO 20 INVAL = 1, NNVALS
         N = NVALS( INVAL )
*           Re-initialise X each time to avoid overflow.
         DO 10 I = 1, N*INCX
            X( I ) = I*1.013E0
   10    CONTINUE
         S0 = SECOND( )
         S1 = SECOND( )
         CALL STPSV( UPLO, TRANS, 'N', N, A, X, INCX )
         S2 = SECOND( )
         TIME = ( S2 - S1 ) - ( S1 - S0 )
         NOP = N*N
         IF( TIME.LE.0.0E0 )THEN
            RESLTS( 1, INVAL ) = 0.0E0
         ELSE
            RESLTS( 1, INVAL ) = NOP/( 1.0E6*TIME )
         END IF
   20 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM12( NMAX, MVALS, NMVALS, NVALS, NNVALS, A, LDA,
     $                   INCX, X, Y, LDRES, RESLTS )
*     Times SGER.
*     .. Parameters ..
      REAL               ALPHA
      PARAMETER          ( ALPHA = -0.9E0 )
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, LDRES, NMAX, NMVALS, NNVALS
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX ), Y( NMAX*INCX )
      INTEGER            MVALS( NMVALS ), NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, IMVAL, INVAL, J, M, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           SGER
*     .. Intrinsic Functions ..
      INTRINSIC          MIN, REAL
*     .. Executable Statements ..
      DO 40 IMVAL = 1, NMVALS
         M = MVALS( IMVAL )
         DO 30 INVAL = 1, NNVALS
            N = NVALS( INVAL )
*           Re-initialise A each time to avoid overflow.
            DO 20 J = 1, N
               DO 10 I = 1, M
                  A( I, J ) = 1.0E0 + REAL( ( J - 1 )*N + I )/
     $                        REAL( M*N + 1 )
   10          CONTINUE
   20       CONTINUE
            S0 = SECOND( )
            S1 = SECOND( )
            CALL SGER( M, N, ALPHA, X, INCX, Y, INCX, A, LDA )
            S2 = SECOND( )
            TIME = ( S2 - S1 ) - ( S1 - S0 )
            NOP = 2*M*N + MIN( M, N )
            IF( TIME.LE.0.0E0 )THEN
               RESLTS( IMVAL, INVAL ) = 0.0E0
            ELSE
               RESLTS( IMVAL, INVAL ) = NOP/( 1.0E6*TIME )
            END IF
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM13( UPLO, NMAX, NVALS, NNVALS, A, LDA, INCX, X,
     $                   LDRES, RESLTS )
*     Times SSYR.
*     .. Parameters ..
      REAL               ALPHA
      PARAMETER          ( ALPHA = -0.9E0 )
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, LDRES, NMAX, NNVALS
      CHARACTER*1        UPLO
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX )
      INTEGER            NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, INVAL, J, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           SSYR
*     .. Intrinsic Functions ..
      INTRINSIC          REAL
*     .. Executable Statements ..
      DO 30 INVAL = 1, NNVALS
         N = NVALS( INVAL )
*           Re-initialise A each time to avoid overflow.
         DO 20 J = 1, N
            DO 10 I = 1, N
               A( I, J ) = 1.0E0 + REAL( ( J - 1 )*N + I )/
     $                     REAL( N*N + 1 )
   10       CONTINUE
   20    CONTINUE
         S0 = SECOND( )
         S1 = SECOND( )
         CALL SSYR( UPLO, N, ALPHA, X, INCX, A, LDA )
         S2 = SECOND( )
         TIME = ( S2 - S1 ) - ( S1 - S0 )
         NOP = N*( N + 1 ) + N
         IF( TIME.LE.0.0E0 )THEN
            RESLTS( 1, INVAL ) = 0.0E0
         ELSE
            RESLTS( 1, INVAL ) = NOP/( 1.0E6*TIME )
         END IF
   30 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM14( UPLO, NMAX, NVALS, NNVALS, A, LDA, INCX, X,
     $                   LDRES, RESLTS )
*     Times SSPR.
*     .. Parameters ..
      REAL               ALPHA
      PARAMETER          ( ALPHA = -0.9E0 )
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, LDRES, NMAX, NNVALS
      CHARACTER*1        UPLO
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX )
      INTEGER            NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, INVAL, J, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           SSPR
*     .. Intrinsic Functions ..
      INTRINSIC          REAL
*     .. Executable Statements ..
      DO 30 INVAL = 1, NNVALS
         N = NVALS( INVAL )
*           Re-initialise A each time to avoid overflow.
         DO 20 J = 1, N
            DO 10 I = 1, N
               A( I, J ) = 1.0E0 + REAL( ( J - 1 )*N + I )/
     $                     REAL( N*N + 1 )
   10       CONTINUE
   20    CONTINUE
         S0 = SECOND( )
         S1 = SECOND( )
         CALL SSPR( UPLO, N, ALPHA, X, INCX, A )
         S2 = SECOND( )
         TIME = ( S2 - S1 ) - ( S1 - S0 )
         NOP = N*( N + 1 ) + N
         IF( TIME.LE.0.0E0 )THEN
            RESLTS( 1, INVAL ) = 0.0E0
         ELSE
            RESLTS( 1, INVAL ) = NOP/( 1.0E6*TIME )
         END IF
   30 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM15( UPLO, NMAX, NVALS, NNVALS, A, LDA, INCX, X, Y,
     $                   LDRES, RESLTS )
*     Times SSYR2.
*     .. Parameters ..
      REAL               ALPHA
      PARAMETER          ( ALPHA = -0.9E0 )
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO
      INTEGER            INCX, LDA, LDRES, NMAX, NNVALS
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX ), Y( NMAX*INCX )
      INTEGER            NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, INVAL, J, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           SSYR2
*     .. Intrinsic Functions ..
      INTRINSIC          REAL
*     .. Executable Statements ..
      DO 30 INVAL = 1, NNVALS
         N = NVALS( INVAL )
*           Re-initialise A each time to avoid overflow.
         DO 20 J = 1, N
            DO 10 I = 1, N
               A( I, J ) = 1.0E0 + REAL( ( J - 1 )*N + I )/
     $                     REAL( N*N + 1 )
   10       CONTINUE
   20    CONTINUE
         S0 = SECOND( )
         S1 = SECOND( )
         CALL SSYR2( UPLO, N, ALPHA, X, INCX, Y, INCX, A, LDA )
         S2 = SECOND( )
         TIME = ( S2 - S1 ) - ( S1 - S0 )
         NOP = 2*( N + 1 )*N + 2*N
         IF( TIME.LE.0.0E0 )THEN
            RESLTS( 1, INVAL ) = 0.0E0
         ELSE
            RESLTS( 1, INVAL ) = NOP/( 1.0E6*TIME )
         END IF
   30 CONTINUE
      RETURN
      END
*
      SUBROUTINE STIM16( UPLO, NMAX, NVALS, NNVALS, A, LDA, INCX, X, Y,
     $                   LDRES, RESLTS )
*     Times SSPR2.
*     .. Parameters ..
      REAL               ALPHA
      PARAMETER          ( ALPHA = -0.9E0 )
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO
      INTEGER            INCX, LDA, LDRES, NMAX, NNVALS
*     .. Array Arguments ..
      REAL               A( LDA, NMAX ), RESLTS( LDRES, NNVALS ),
     $                   X( NMAX*INCX ), Y( NMAX*INCX )
      INTEGER            NVALS( NNVALS )
*     .. Local Scalars ..
      REAL               S0, S1, S2, TIME
      INTEGER            I, INVAL, J, N, NOP
*     .. External Functions ..
      REAL               SECOND
      EXTERNAL           SECOND
*     .. External Subroutines ..
      EXTERNAL           SSPR2
*     .. Intrinsic Functions ..
      INTRINSIC          REAL
*     .. Executable Statements ..
      DO 30 INVAL = 1, NNVALS
         N = NVALS( INVAL )
*           Re-initialise A each time to avoid overflow.
         DO 20 J = 1, N
            DO 10 I = 1, N
               A( I, J ) = 1.0E0 + REAL( ( J - 1 )*N + I )/
     $                     REAL( N*N + 1 )
   10       CONTINUE
   20    CONTINUE
         S0 = SECOND( )
         S1 = SECOND( )
         CALL SSPR2( UPLO, N, ALPHA, X, INCX, Y, INCX, A )
         S2 = SECOND( )
         TIME = ( S2 - S1 ) - ( S1 - S0 )
         NOP = 2*( N + 1 )*N + 2*N
         IF( TIME.LE.0.0E0 )THEN
            RESLTS( 1, INVAL ) = 0.0E0
         ELSE
            RESLTS( 1, INVAL ) = NOP/( 1.0E6*TIME )
         END IF
   30 CONTINUE
      RETURN
      END


*DECK SROT
      SUBROUTINE SROT (N, SX, INCX, SY, INCY, SC, SS)
C***BEGIN PROLOGUE  SROT
C***PURPOSE  Apply a plane Givens rotation.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A8
C***TYPE      SINGLE PRECISION (SROT-S, DROT-D, CSROT-C)
C***KEYWORDS  BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION,
C             LINEAR ALGEBRA, PLANE ROTATION, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C       SY  single precision vector with N elements
C     INCY  storage spacing between elements of SY
C       SC  element of rotation matrix
C       SS  element of rotation matrix
C
C     --Output--
C       SX  rotated vector SX (unchanged if N .LE. 0)
C       SY  rotated vector SY (unchanged if N .LE. 0)
C
C     Multiply the 2 x 2 matrix  ( SC SS) times the 2 x N matrix (SX**T)
C                                (-SS SC)                        (SY**T)
C     where **T indicates transpose.  The elements of SX are in
C     SX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else
C     LX = 1+(1-N)*INCX, and similarly for SY using LY and INCY.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SROT
      REAL SX, SY, SC, SS, ZERO, ONE, W, Z
      DIMENSION SX(*), SY(*)
      SAVE ZERO, ONE
      DATA ZERO, ONE /0.0E0, 1.0E0/
C***FIRST EXECUTABLE STATEMENT  SROT
      IF (N .LE. 0 .OR. (SS .EQ. ZERO .AND. SC .EQ. ONE)) GO TO 40
      IF (.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20
C
C          Code for equal and positive increments.
C
           NSTEPS=INCX*N
           DO 10 I = 1,NSTEPS,INCX
                W=SX(I)
                Z=SY(I)
                SX(I)=SC*W+SS*Z
                SY(I)=-SS*W+SC*Z
   10           CONTINUE
           GO TO 40
C
C     Code for unequal or nonpositive increments.
C
   20 CONTINUE
           KX=1
           KY=1
C
           IF (INCX .LT. 0) KX = 1-(N-1)*INCX
           IF (INCY .LT. 0) KY = 1-(N-1)*INCY
C
           DO 30 I = 1,N
                W=SX(KX)
                Z=SY(KY)
                SX(KX)=SC*W+SS*Z
                SY(KY)=-SS*W+SC*Z
                KX=KX+INCX
                KY=KY+INCY
   30           CONTINUE
   40 CONTINUE
C
      RETURN
      END


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      subroutine heapsort(a,n)

      dimension a(0:*)
      integer n

      integer start, bottom
      real temp

      do start = (n-2)/2, 0, -1
        call hs_siftdown(a, start, n)
      end do

      do bottom = n-1, 1, -1
        temp = a(0)
        a(0) = a(bottom)
        a(bottom) = temp
        call hs_siftdown(a, 0, bottom)
      end do
      end

      subroutine hs_siftdown(a, start, bottom)

      real a(0:*)
      integer start, bottom
      integer child, root
      real temp

      root = start
      do while(root*2 + 1 .lt. bottom)
        child = root * 2 + 1

        if ((child + 1 .lt. bottom) .and.
     *    (a(child) .lt. a(child+1))) then
          child = child + 1
        end if

        if (a(root) .lt. a(child)) then
          temp = a(child)
          a(child) = a (root)
          a(root) = temp
          root = child
        else
          return
        end if
      end do
      return
      end


module matrix_multiplication_test_helper_module
    use, intrinsic :: iso_fortran_env, only : &
            real32, &
            real64

    use :: util_api, only : &
            assert, &
            string, &
            dictionary

    use :: data_api, only : &
            storage_helper, &
            stream_handler, &
            stream, &
            concurrency_factory

    use :: tensor_api, only : &
            scalar, &
            matrix, &
            copy_tensor

    use :: algorithms_api, only : &
            matrix_multiplication, &
            matrix_multiplication_factory

    implicit none
    private

    public :: matrix_multiplication_test_helper

    type :: matrix_multiplication_test_helper
    contains
        procedure :: run => run
        procedure, nopass :: run_real32 => run_real32
        procedure, nopass :: run_real64 => run_real64
        procedure, nopass :: run_complex64 => run_complex64
        procedure, nopass :: run_complex128 => run_complex128
    end type matrix_multiplication_test_helper

    real(real32), parameter :: single = 1.0e-4
    real(real64), parameter :: double = 1.0d-13
contains
    subroutine run(this, assertion, prefix, driver, memory_type, options, priorities)
        class(matrix_multiplication_test_helper), intent(in) :: this
        type(assert), intent(inout) :: assertion
        character(len=*), intent(in) :: prefix
        character(len=*), intent(in), optional :: driver, memory_type
        type(dictionary), intent(in), optional :: options
        type(string), dimension(:), intent(in), optional :: priorities

        call this%run_real32(assertion, prefix//"real32:", driver, memory_type, options, priorities)
        call this%run_real64(assertion, prefix//"real64:", driver, memory_type, options, priorities)
        call this%run_complex64(assertion, prefix//"complex64:", driver, memory_type, options, priorities)
        call this%run_complex128(assertion, prefix//"complex128:", driver, memory_type, options, priorities)
    end subroutine run

    subroutine run_real32(assertion, prefix, driver, memory_type, options, priorities)
        type(assert), intent(inout) :: assertion
        character(len=*), intent(in) :: prefix
        character(len=*), intent(in), optional :: driver, memory_type
        type(dictionary), intent(in), optional :: options
        type(string), dimension(:), intent(in), optional :: priorities

        type(matrix) :: a, b, c
        integer :: m, n, k
        real(real32), dimension(:,:), allocatable :: am, bm, cm
        type(storage_helper) :: helper
        class(matrix_multiplication), allocatable :: mm
        class(stream_handler), allocatable :: handler
        type(stream) :: astream

        a = matrix(); b=matrix(); c=matrix()
        call matrix_multiplication_factory%create(mm, driver, options, priorities)

        m = 20; n = 30; k = 50
        allocate(am(m, k), bm(k, n), cm(m,n))
        am = 0.0; bm=0.0; cm=0.0

        call copy_tensor(a, am, memory_type, options, priorities)
        call copy_tensor(b, bm, memory_type, options, priorities)
        call copy_tensor(c, cm, memory_type, options, priorities)

        call mm%mm(c, a, b)

        call assertion%equal(prefix//"::Product of zero matrices", &
                helper%equal(c%storage, cm, single))

        call a%cleanup(); call b%cleanup(); call c%cleanup()

        call random_number(am)
        call random_number(bm)
        cm=0.0

        call copy_tensor(a, am, memory_type, options, priorities)
        call copy_tensor(b, bm, memory_type, options, priorities)
        call copy_tensor(c, cm, memory_type, options, priorities)

        call concurrency_factory%create_default_stream_handler(handler, memory_type, options, priorities)
        call handler%create(astream)
        cm = matmul(am, bm)

        call mm%mm(c, a, b, astream=astream)
        call mm%synchronize(astream)
        call handler%destroy(astream)
        deallocate(handler)
        call assertion%equal(prefix//"::Product of random matrices", &
                helper%equal(c%storage, cm, single))

        call mm%mm(c, a, b)
        call mm%mm(c, a, b)
        call assertion%equal(prefix//"::Product of random matrices twice", &
                helper%equal(c%storage, cm, single))
        call a%cleanup(); call b%cleanup(); call c%cleanup()

        call mm%cleanup()
        deallocate(mm)
        deallocate(am, bm, cm)
    end subroutine run_real32

    subroutine run_real64(assertion, prefix, driver, memory_type, options, priorities)
        type(assert), intent(inout) :: assertion
        character(len=*), intent(in) :: prefix
        character(len=*), intent(in), optional :: driver, memory_type
        type(dictionary), intent(in), optional :: options
        type(string), dimension(:), intent(in), optional :: priorities

        type(matrix) :: a, b, c
        integer :: m, n, k
        real(real64), dimension(:,:), allocatable :: am, bm, cm
        type(storage_helper) :: helper
        class(matrix_multiplication), allocatable :: mm
        class(stream_handler), allocatable :: handler
        type(stream) :: astream

        a = matrix(); b=matrix(); c=matrix()
        call matrix_multiplication_factory%create(mm, driver, options, priorities)

        m = 20; n = 30; k = 50
        allocate(am(m, k), bm(k, n), cm(m,n))
        am = 0.0d0; bm=0.0d0; cm=0.0d0

        call copy_tensor(a, am, memory_type, options, priorities)
        call copy_tensor(b, bm, memory_type, options, priorities)
        call copy_tensor(c, cm, memory_type, options, priorities)

        call mm%mm(c, a, b)

        call assertion%equal(prefix//"::Product of zero matrices", &
                helper%equal(c%storage, cm, double))

        call a%cleanup(); call b%cleanup(); call c%cleanup()

        call random_number(am)
        call random_number(bm)
        cm=0.0d0

        call copy_tensor(a, am, memory_type, options, priorities)
        call copy_tensor(b, bm, memory_type, options, priorities)
        call copy_tensor(c, cm, memory_type, options, priorities)

        cm = matmul(am, bm)

        call concurrency_factory%create_default_stream_handler(handler, memory_type, options, priorities)
        call handler%create(astream)
        call mm%mm(c, a, b, astream=astream)
        call mm%synchronize(astream)
        call handler%destroy(astream)
        deallocate(handler)

        call assertion%equal(prefix//"::Product of random matrices", &
                helper%equal(c%storage, cm, double))

        call mm%mm(c, a, b)
        call mm%mm(c, a, b)
        call assertion%equal(prefix//"::Product of random matrices twice", &
                helper%equal(c%storage, cm, double))
        call a%cleanup(); call b%cleanup(); call c%cleanup()

        call mm%cleanup()
        deallocate(mm)
        deallocate(am, bm, cm)
    end subroutine run_real64

    subroutine run_complex64(assertion, prefix, driver, memory_type, options, priorities)
        type(assert), intent(inout) :: assertion
        character(len=*), intent(in) :: prefix
        character(len=*), intent(in), optional :: driver, memory_type
        type(dictionary), intent(in), optional :: options
        type(string), dimension(:), intent(in), optional :: priorities

        type(matrix) :: a, b, c
        integer :: m, n, k
        complex(real32), dimension(:,:), allocatable :: am, bm, cm
        real(real32), dimension(:,:), allocatable :: are, aim, bre, bim
        type(storage_helper) :: helper
        class(matrix_multiplication), allocatable :: mm
        complex(real32) :: tolerance
        class(stream_handler), allocatable :: handler
        type(stream) :: astream

        a = matrix(); b=matrix(); c=matrix()
        tolerance = (single,single)

        call matrix_multiplication_factory%create(mm, driver, options, priorities)

        m = 20; n = 30; k = 50
        allocate(am(m, k), bm(k, n), cm(m,n))
        allocate(are(m, k), aim(m, k))
        allocate(bre(k, n), bim(k, n))
        am = (0.0, 0.0); bm=(0.0, 0.0); cm=(0.0, 0.0)

        call copy_tensor(a, am, memory_type, options, priorities)
        call copy_tensor(b, bm, memory_type, options, priorities)
        call copy_tensor(c, cm, memory_type, options, priorities)

        call mm%mm(c, a, b)

        call assertion%equal(prefix//"::Product of zero matrices", &
                helper%equal(c%storage, cm, tolerance))

        call a%cleanup(); call b%cleanup(); call c%cleanup()

        call random_number(are)
        call random_number(aim)
        call random_number(bre)
        call random_number(bim)
        am = cmplx(are, aim)
        bm = cmplx(bre, bim)

        cm=(0.0, 0.0)

        call copy_tensor(a, am, memory_type, options, priorities)
        call copy_tensor(b, bm, memory_type, options, priorities)
        call copy_tensor(c, cm, memory_type, options, priorities)

        cm = matmul(am, bm)

        call concurrency_factory%create_default_stream_handler(handler, memory_type, options, priorities)
        call handler%create(astream)
        call mm%mm(c, a, b, astream=astream)
        call mm%synchronize(astream)
        call handler%destroy(astream)
        deallocate(handler)

        call assertion%equal(prefix//"::Product of random matrices", &
                helper%equal(c%storage, cm, tolerance))

        call mm%mm(c, a, b)
        call mm%mm(c, a, b)
        call assertion%equal(prefix//"::Product of random matrices twice", &
                helper%equal(c%storage, cm, tolerance))
        call a%cleanup(); call b%cleanup(); call c%cleanup()

        call mm%cleanup()
        deallocate(mm)
        deallocate(am, bm, cm, are, aim, bre, bim)
    end subroutine run_complex64

    subroutine run_complex128(assertion, prefix, driver, memory_type, options, priorities)
        type(assert), intent(inout) :: assertion
        character(len=*), intent(in) :: prefix
        character(len=*), intent(in), optional :: driver, memory_type
        type(dictionary), intent(in), optional :: options
        type(string), dimension(:), intent(in), optional :: priorities

        type(matrix) :: a, b, c
        integer :: m, n, k
        complex(real64), dimension(:,:), allocatable :: am, bm, cm
        real(real64), dimension(:,:), allocatable :: are, aim, bre, bim
        type(storage_helper) :: helper
        class(matrix_multiplication), allocatable :: mm
        complex(real64) :: tolerance
        class(stream_handler), allocatable :: handler
        type(stream) :: astream

        a = matrix(); b=matrix(); c=matrix()
        tolerance = (double,double)

        call matrix_multiplication_factory%create(mm, driver, options, priorities)

        m = 20; n = 30; k = 50
        allocate(am(m, k), bm(k, n), cm(m,n))
        allocate(are(m, k), aim(m, k))
        allocate(bre(k, n), bim(k, n))
        am = (0.0d0, 0.0d0); bm=(0.0d0, 0.0d0); cm=(0.0d0, 0.0d0)

        call copy_tensor(a, am, memory_type, options, priorities)
        call copy_tensor(b, bm, memory_type, options, priorities)
        call copy_tensor(c, cm, memory_type, options, priorities)

        call mm%mm(c, a, b)

        call assertion%equal(prefix//"::Product of zero matrices", &
                helper%equal(c%storage, cm, tolerance))

        call a%cleanup(); call b%cleanup(); call c%cleanup()

        call random_number(are)
        call random_number(aim)
        call random_number(bre)
        call random_number(bim)
        am = cmplx(are, aim, kind=real64)
        bm = cmplx(bre, bim, kind=real64)

        cm=(0.0d0, 0.0d0)

        call copy_tensor(a, am, memory_type, options, priorities)
        call copy_tensor(b, bm, memory_type, options, priorities)
        call copy_tensor(c, cm, memory_type, options, priorities)

        cm = matmul(am, bm)

        call concurrency_factory%create_default_stream_handler(handler, memory_type, options, priorities)
        call handler%create(astream)
        call mm%mm(c, a, b, astream=astream)
        call mm%synchronize(astream)
        call handler%destroy(astream)
        deallocate(handler)

        call assertion%equal(prefix//"::Product of random matrices", &
                helper%equal(c%storage, cm, tolerance))

        call mm%mm(c, a, b)
        call mm%mm(c, a, b)
        call assertion%equal(prefix//"::Product of random matrices twice", &
                helper%equal(c%storage, cm, tolerance))
        call a%cleanup(); call b%cleanup(); call c%cleanup()

        call mm%cleanup()
        deallocate(mm)
        deallocate(am, bm, cm, are, aim, bre, bim)
    end subroutine run_complex128
end module matrix_multiplication_test_helper_module


program pgm
real c,d
integer :: i = 3
c = 10.01

if (c > 10.0) then
  if (i >= 3) c = c + 10.32
else
  c = c - 3.12
endif

print *, c
end


subroutine square_cube(i,isquare, icube,iasdfljaksdfhalsdjkfhasldkfashfasdfsafsdfasdfs)
  integer, intent(in) :: i
  integer, intent(out) :: isquare, icube
  isquare = i ** 2
  icube = i ** 3
end subroutine square_cube


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*--- Induction initial values, update reaching defs
*

	program p
	parameter (N=16)
	integer i, j
	double precision expect(N)
	double precision result(100)
	common /c/ result

	call cnstnt(4,result)

	data expect /
     +    1.0, 1.0, 1.0, 1.0, 1.0, 2.0, 3.0, 0.0,
     +    1.0, 3.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0 /

	call checkd(result, expect, N)
	end
C***********************************************************************
      SUBROUTINE CNSTNT(N,C)
      IMPLICIT DOUBLEPRECISION(A-H,O-Z)
      DIMENSION C(N,N)
C
C.....MOLECULAR CONSTANTS FOR WATER IN ANGSTROM, RADIAN, AND A.M.U.
C
      C(1,1)=1.0D0
      DO 1000 N1=2,N
	  NN=N1-1
	  TN=NN
	  C(1,N1)=1.0D0
	  TK=1.0D0
	  DO 1100 K1=2,N1
	      C(K1,NN)=C(K1-1,NN+1)*TN/TK
	      NN=NN-1
	      TN=TN-1.0D0
	      TK=TK+1.0D0
1100      CONTINUE
1000  CONTINUE
	return
	end


      MODULE nine0_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90 4.3E  10:07:58  11/16/01
      SUBROUTINE nine0 (J1, J2, J3, L1, L2, L3, K1, K2, K3, AA)
      USE vast_kind_param,ONLY: DOUBLE
      INTEGER, INTENT(IN) :: J1
      INTEGER, INTENT(IN) :: J2
      INTEGER, INTENT(IN) :: J3
      INTEGER, INTENT(IN) :: L1
      INTEGER, INTENT(IN) :: L2
      INTEGER, INTENT(IN) :: L3
      INTEGER, INTENT(IN) :: K1
      INTEGER, INTENT(IN) :: K2
      INTEGER, INTENT(IN) :: K3
      REAL(DOUBLE), INTENT(OUT) :: AA
!VAST.../CONSTS/ ZERO(IN), ONE(IN)
!VAST...Calls: SIXJ
      END SUBROUTINE
      END INTERFACE
      END MODULE


real function pindex(nx, press, obspressure)
! This routine handles press (pressure) in decendent order (bottom2top)
! press(1): highest pressure value
! press(nx): lowerest pressure value

use kinds
implicit none

integer :: ix, k, nx
real(kind_real) :: ozp, obspressure, psi
real(kind_real), dimension(nx) :: press

psi = 1.0_kind_real/press(1)
if(obspressure*psi < 1.) then
  ozp = obspressure
else
  ozp = press(1)
endif
if( ozp >= press(1)) then
  ix = 1
else
  ix = 0
  do k = 1, nx-1
    if(ozp >= press(k)) then
      ix = k
      exit
    endif
  enddo
  if(ix == 0) ix = nx
  if(ix > 1)ix = ix -1
endif
ozp = float(ix) + &
    (ozp-press(ix))/(press(ix+1)-press(ix))
pindex = ozp
return
end


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c                                                                             c
c                  Calculating the Peak Likelihood of the ZDCF                c
c                                                                             c
c        A special version for processing the ZDCF output file *.dcf          c
c                                                                             c
c                                Version 3.0                                  c
c                                                                             c
c    (Bayesian prior assumption of uniform distribution in z-space)           c
c                                                                             c
c                                                                             c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c                                                                             c
c SAMPLE RUN (user input marked by "<-USER". See explanations below)          c
c ----------                                                                  c
c                                                                             c
c PLIKE V3.0 begins.                                                          c
c Enter dcf file name:                                                        c
c test.dcf       <-USER                                                       c
c Enter lower bound on peak location:                                         c
c -200           <-USER                                                       c
c Enter upper bound on peak location:                                         c
c 200            <-USER                                                       c
c Calculating ML in range  -200.  to  200.                                    c
c                                                                             c
c ZDCF peak at  +0.133     r_max =  +0.881     , ZDCF C.O.M at   -4.31        c
c                                                                             c
c  #      lag         r         -dr        +dr    likelihood                  c
c --- ---------- ---------- ---------- ---------- ----------                  c
c  1  -76.8      0.355      0.314      0.275      2.701E-03                   c
c  2  -19.8      0.780      0.121      9.680E-02  0.111                       c
c  3  0.133      0.881      8.032E-02  6.053E-02  0.458                       c
c  4   5.62      0.821      0.124      9.322E-02  0.205                       c
c  5   24.1      0.392      0.306      0.265      3.669E-03                   c
c  6   87.5     -0.162      0.319      0.339      2.365E-05                   c
c  7   200.     -0.435      0.251      0.295      7.652E-07                   c
c                                                                             c
c ML Peak at  +0.133     , L at peak =  +0.458                                c
c 1 sigma ML interval =  +0.133       +10.0       -23.7                       c
c                     = (  -23.6     ,   +10.2    )                           c
c                                                                             c
c Program ended.                                                              c
c                                                                             c
c EXPLANATION                                                                 c
c -----------                                                                 c
c                                                                             c
c o The program uses the *.dcf output file of the ZDCF.                       c
c                                                                             c
c o The user has to give lower and upper bounds on the peak location          c
c                                                                             c
c o The output consists of the likelihood function and the fiducial interval, c
c   given both as t_peak + dt_up - dt_low, and as the interval (t_min, t_max) c
c                                                                             c
c FORTRAN ISSUES                                                              c
c --------------                                                              c
c                                                                             c
c o Compile with static variables flag:                                       c
c      Intel Fortran: ifort -save -o plike plike_v3.0.f                       c
c      g77 Fortran: g77 -fno-automatic  -o plike plike_v3.0.f                 c
c      g95 Fortran: g95 -fstatic  -o plike plike_v3.0.f                       c
c      Other compilers: -static (?)                                           c
c                                                                             c
c o The program can be VERY slow - don't panic!                               c
c                                                                             c
c o This program incorporates the functions QROMO, POLINT and MIDPNT          c
c   from Numerical Recipes / Press, Flannery, Teukolsky & Vetterling.         c
c                                                                             c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
      integer i,np,maxp
      parameter (maxp = 200)
      integer n(maxp)
      real t(maxp),dtm(maxp),dtp(maxp),r(maxp),drm(maxp),drp(maxp)
      real liklhd(maxp),mxlik,tmxlik
      real tlow,thigh,dtlikl,dtliku,tcom
      character*72 dcf
      integer oerr,cerr
      real com
c
      print *,'PLIKE V3.0 begins.'
c
      print *,'Enter dcf file name:'
      read '(a72)',dcf
      open (unit=11,file=dcf,status='OLD',iostat=oerr,err=901)
c
      print *,'Enter lower bound on peak location:'
      read *,tlow
      print *,'Enter upper bound on peak location:'
      read *,thigh
      print *,'Calculating ML in range ',tlow,' to ', thigh
      np = 0
1     continue
         if (np .ge. maxp) then
            print *,'Only 1st ',maxp,' points were read!'
            goto 2
         endif
         read (11,*,end=2)
     >      t(np+1),dtm(np+1),dtp(np+1),
     >      r(np+1),drm(np+1),drp(np+1),n(np+1)
         if (t(np+1) .lt. tlow .or. t(np+1) .gt. thigh) goto 1
         np = np+1
         goto 1
2     continue
      close (unit=11,status='KEEP',iostat=cerr,err=902)
c
      print *
      tcom = com(t,r,np,i)
      print '(''ZDCF peak at '',sp,1p,g11.3,'' r_max = '',g11.3,
     >        '' , ZDCF C.O.M at '',g11.3)',t(i),r(i),tcom
      call plike3(t,dtm,dtp,r,drm,drp,n,np,tlow,thigh,
     >            liklhd,tmxlik,mxlik,dtlikl,dtliku,2)
c
      print *
      print *,
     >' #      lag         r         -dr        +dr    likelihood '
      print *,
     >'--- ---------- ---------- ---------- ---------- ---------- '
      print '(i3,'' '',1p,g10.3,1x,g10.3,1x,g10.3,1x,g10.3,1x,g10.3)',
     >   (i,t(i),r(i),drm(i),drp(i),liklhd(i),i=1,np)
c
      print *
      print '(''ML Peak at '',sp,1p,g11.3,'' , L at peak = '',g11.3)',
     >   tmxlik,mxlik
      print '(''1 sigma ML interval = '',sp,1p,g11.3,1x,g11.3,1x,
     >        g11.3,/,19x,'' = ('',g11.3,'' , '',g11.3,'')'')',
     >   tmxlik,dtliku,-dtlikl,tmxlik-dtlikl,tmxlik+dtliku
      print *
      print *,'Program ended.'
      stop
 901  print *,'ERROR ON OPENING FILE - ERRCOD=',oerr
      stop
 902  print *,'ERROR ON CLOSING FILE - ERRCOD=',cerr
      stop
      end
c//////////////////////////////////////////////////////////////////////////////
c
c com calculates the center-of-mass (centroid) around the ZDCF peak.
c The sum is taken over all the points lying between the two nearest
c the maximum with r < r_max/2.
c
      real function com(t,r,n,imax)
      implicit none
      integer n,imax,nerr
      real t(n),r(n)
      real sumr,sumtr,rhalf
      integer i,i1,i2
c Locating the maximum
      imax = 1
      do i = 1,n
         if (r(imax) .lt. r(i)) imax = i
      enddo
c
      rhalf = r(imax)/2.
c Locating the peak
      i1 = imax-1
      do while (i1.ge.1 .and. r(i1).ge.rhalf)
         i1 = i1-1
      enddo
      i1 = i1+1
c Warning
      if (i1.eq.1 .and. r(1).ge.rhalf) then
         print *,
     >      'COM: Warning - Peak extends beyond range to the left...'
      endif
c
      i2 = imax+1
      do while (i2.le.n .and. r(i2).ge.rhalf)
         i2 = i2+1
      enddo
      i2 = i2-1
c Warning
      if (i2.eq.n .and. r(n).ge.rhalf) then
         print *,
     >      'COM: Warning - Peak extends beyond range to the right...'
         nerr = nerr+1
      endif
c Calculating the center of mass
      sumtr = 0.0
      sumr = 0.0
      do i = i1,i2
         sumtr = sumtr+t(i)*r(i)
         sumr = sumr+r(i)
      enddo
      if (sumr .le. 0.0) then
         print *,'COM: Problems. n = ',n,' imax = ',imax,
     >           ' rmax = ',r(imax),
     >           ' i1 = ',i1,' i2 = ',i2,' sumr = ',sumr
         print '(1x,f10.3,1x,f10.3)',(t(i),r(i),i=1,n)
         stop
      else
         com = sumtr/sumr
      endif
      return
      end
c//////////////////////////////////////////////////////////////////////////////
cold      include "/home/tal/ZDCF/src/plike_func3.f"
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c                                                                             c
c                  Calculating the Peak Likelihood of the ZDCF                c
c                                                                             c
c        A special version for processing the ZDCF output file *.dcf          c
c                                                                             c
c                                Version 3.0                                  c
c                                                                             c
c    (Bayesian prior assumption of uniform distribution in z-space)           c
c                                                                             c
c                                                                             c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c                                                                             c
c SAMPLE RUN (user input marked by "<-USER". See explanations below)          c
c ----------                                                                  c
c                                                                             c
c PLIKE V3.0 begins.                                                          c
c Enter dcf file name:                                                        c
c test.dcf      <-USER                                                        c
c Enter lower bound on peak location:                                         c
c -200           <-USER                                                       c
c Enter upper bound on peak location:                                         c
c 200            <-USER                                                       c
c Working on   7 points                                                       c
c                                                                             c
c   i       tau        z          s_z       likelihood                        c
c -----------------------------------------------------                       c
c    1  -76.77000    0.39168    0.35056     3.2769E-03                        c
c    2  -19.79000    1.07518    0.28485     0.1270                            c
c    3    0.13330    1.42651    0.32573     0.5923                            c
c    4    5.61800    1.20773    0.34551     0.2729                            c
c    5   24.10000    0.43595    0.35034     4.4965E-03                        c
c    6   87.48000   -0.17234    0.35143     2.2088E-05                        c
c    7  199.89999   -0.49122    0.35009     4.8453E-07                        c
c                                                                             c
c Peak at 0.133     , ML(peak) = 0.592                                        c
c 1 sigma ML interval =  0.133    + 13.4    -  23.9                           c
c                     = ( -23.8     ,   13.5    )                             c
c                                                                             c
c Program ended.                                                              c
c                                                                             c
c EXPLANATION                                                                 c
c -----------                                                                 c
c                                                                             c
c o The program uses the *.dcf output file of the ZDCF.                       c
c                                                                             c
c o The user has to give lower and upper bounds on the peak location          c
c                                                                             c
c o The output consists of the likelihood function and the fiducial interval, c
c   given both as t_peak + dt_up - dt_low, and as the interval (t_min, t_max) c
c                                                                             c
c FORTRAN ISSUES                                                              c
c --------------                                                              c
c                                                                             c
c o The program is VERY slow - don't panic!                                   c
c                                                                             c
c o This program incorporates the functions QROMO, POLINT and MIDPNT          c
c   from Numerical Recipes / Press, Flannery, Teukolsky & Vetterling.         c
c                                                                             c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine plike3(t,dtm,dtp,r,drm,drp,n,np0,tlow,thigh,
c                      i i   i   i i  i  i i i   i    i
     >                 liklhd,tmxlik,mxlik,dtlikl,dtliku,zrflag)
c                      o      o      o     o      o      i
      implicit none
      integer np0,zrflag
      real tlow,thigh,tmxlik,mxlik,dtlikl,dtliku
      real t(np0),dtm(np0),dtp(np0),r(np0),drm(np0),drp(np0),liklhd(np0)
      integer n(np0)
c
      integer i,maxp,np,ilow
      parameter (maxp = 200)
      integer pnt(maxp)
      real z(maxp),pcum(maxp)
      real p,rpeak
      integer imxlik,ipeak
      real eps,epslik,tiny,maxsig
      parameter (eps = 1e-6, epslik = 1e-10, tiny = 1e-30, maxsig = 5)
      real likint,likin0,likin1
      external likint,midpt1
c
      np = 0
      ilow = 0
      rpeak = -1.0
c     Input given in z-space (zrflag = 1): vector r holds z
      if (zrflag .eq. 1) then
         do i = 1,np0
            if (t(i) .ge. tlow .and. t(i) .le. thigh) then
               np = np+1
               if (np .gt. maxp) then
                  print *,'PLIKE: Work area too small ! ',
     >                 'Increase maxp to >= ',maxp
                  stop
               endif
               z(np) = r(i)
               liklhd(np) = 0.0
               if (r(i) .gt. rpeak) then
                  ipeak = np
                  rpeak = r(i)
               endif
            else if (t(i) .lt. tlow) then
               ilow = i
            endif
         enddo
c     Input given in r-space (rzflag <> 1)
      else
         do i = 1,np0
            if (t(i) .ge. tlow .and. t(i) .le. thigh) then
               np = np+1
               if (np .gt. maxp) then
                  print *,'PLIKE: Work area too small ! ',
     >                 'Increase maxp to >= ',maxp
                  stop
               endif
               z(np)  = log((1.+r(np))/(1.-r(np)))/2
               liklhd(np) = 0.0
               if (r(i) .gt. rpeak) then
                  ipeak = np
                  rpeak = r(i)
               endif
            else if (t(i) .lt. tlow) then
               ilow = i
            endif
         enddo
      endif
c Creating a vector of pointers to cells in t, dtm, dtp which relate to z
      do i = 1,np
         pnt(i) = ilow+i
      enddo
      ilow = ilow+1
c
c Calculating the likelihood function
c
      p = likin0(z,n,np)
      do i = ipeak-1,1,-1
         p = likin1(i)
         print '(''.'',$)'
c Note small modifications of original qromo
         call qromo1(likint,-1d0,1d0,liklhd(i),midpt1)
cdbg(
c         print '(1x,i3,1x,0p,f10.5,1x,f10.5,5x,i3,7x,1p,g10.4)',
c     >         i,t(i),z(i),n(i),liklhd(i)
cdbg)
         if (liklhd(i) .lt. epslik) goto 301
      enddo
 301  continue
      do i = ipeak,np
         p = likin1(i)
         print '(''.'',$)'
c Note small modifications of original qromo
         call qromo1(likint,-1d0,1d0,liklhd(i),midpt1)
cdbg(
c         print '(1x,i3,1x,0p,f10.5,1x,f10.5,5x,i3,7x,1p,g10.4)',
c     >         i,t(i),z(i),n(i),liklhd(i)
cdbg)
         if (liklhd(i) .lt. epslik) goto 302
      enddo
 302  continue
      print '(/)'
c
c Finding the maximal likelihood value and error interval
c
      call conf1(liklhd,t(ilow),dtm(ilow),dtp(ilow),np,
     >           pcum,imxlik,tmxlik,mxlik,dtlikl,dtliku)
c
cdbg      print *
cdbg      print '(''Peak at '',1p,g9.3,'' , ML(peak) = '',g9.3)',
cdbg     >   tmxlik,mxlik
cdbg      print '(''1 sigma ML interval = '',1p,g10.3,''+'',g9.3,''- '',g9.3,
cdbg     >        /,19x,'' = ('',g10.3,'' , '',g10.3,'')'')',
cdbg     >   tmxlik,t1sigu-tmxlik,tmxlik-t1sigl,t1sigl,t1sigu
c
      return
      end
c//////////////////////////////////////////////////////////////////////////////
c
c The integrand of the likelyhood function
c
      real function likint(rho)
      implicit none
      integer maxp
      parameter (maxp = 200)
      real*8 rho
      real z0(*),z(maxp),cn,zbar,sz,dzdr
      integer n0(*),n(maxp)
      integer i0,i,np0,np
c cpi = 1/sqrt(2*Pi)
      integer j
      real cpi,tiny
      parameter (cpi = 0.398942280402, tiny = 1e-10)
      real clike,exp,log
      real likin0,likin1
c
cdbg(
      if (abs(rho) .ge. 1.0) then
	print *,'LIKINT: |rho| >= 1'
	stop
      endif
cdbg)
      zbar = log((1.+rho)/(1.-rho))/2.+rho/2./(n(i)-1)*
     >         (1.+(5.+rho**2)/4./(n(i)-1.)+
     >             (11.+2.*rho**2+3.*rho**4)/8./(n(i)-1)**2)
      sz = sqrt(1./(n(i)-1)*(1.+(4-rho**2)/2./(n(i)-1)+
     >                       (22.-6*rho**2-3*rho**4)/6./(n(i)-1)**2))
      dzdr = 1./(1.+rho)/(1.-rho)
      likint = log(dzdr)+log(cpi)-log(sz)-((z(i)-zbar)/sz)**2/2
      do j = 1,i-1
         cn = clike(rho,z(j),n(j))
         if (cn .le. tiny) then
            likint = 0.0
            return
         endif
         likint = likint+log(cn)
      enddo
      do j = i+1,np
         cn = clike(rho,z(j),n(j))
         if (cn .le. tiny) then
            likint = 0.0
            return
         endif
         likint = likint+log(cn)
      enddo
      likint = exp(likint)
      return
c
      entry likin0(z0,n0,np0)
      if (np .gt. maxp) then
         print *,'LIKINT: maxp too small. np = ',np
         stop
      endif
      np = np0
      do j = 1,np
         z(j) = z0(j)
         n(j) = n0(j)
      enddo
      return
c
      entry likin1(i0)
      i = i0
      return
      end
c///////////////////////////////////////////////////////////////////////
c Integrating over the likelihood function from rho=-1 to rho=rho0 for a
c given value of the estimator r evaluated on n pairs.
      real function clike(rho0,z,n)
      implicit none
      real*8 rho0
      real z
      integer n
c
      real phiz0,phiz1
      external midpt2,phiz1
c
      clike = phiz0(n,z)
cdbg(
      if (abs(rho0) .gt. 1.0) then
	print *,'CLIKE: |rho| > 1'
	stop
      endif
cdbg)

c Note small modifications of original qromo
      call qromo2(phiz1,-1d0,rho0,clike,midpt2)
      return
      end
c///////////////////////////////////////////////////////////////////////
c The integrand of the cumulative likelihood function
c exp(-(z(r)-zbar(rho))/sz(rho))**2/2)/sqrt(2Pi)/sz(rho)
      real function phiz1(rho)
      implicit none
      integer n0,n
      real z0,z
      real*8 rho
      real dzdr,zbar,sz
c sqrpi2 = 1/sqrt(2*Pi)
      real sqrpi2
      parameter (sqrpi2 = .39894228040143267794)
      real sqrt,exp,phiz0
c
cdbg(
      if (abs(rho) .ge. 1.0) then
	print *,'PHIZ1: |rho| >= 1'
	stop
      endif
cdbg)
      zbar = log((1.+rho)/(1.-rho))/2.+rho/2./(n-1)*
     >         (1.+(5.+rho**2)/4./(n-1.)+
     >             (11.+2.*rho**2+3.*rho**4)/8./(n-1)**2)
      sz = sqrt(1./(n-1)*(1.+(4-rho**2)/2./(n-1)+
     >                       (22.-6*rho**2-3*rho**4)/6./(n-1)**2))
      dzdr = 1./(1.+rho)/(1.-rho)
      phiz1 = dzdr*sqrpi2/sz*exp(-((z-zbar)/sz)**2/2)
cdbg      phiz1 = log(dzdr*sqrpi2)-log(sz)-((z-zbar)/sz)**2/2
cdbg      phiz1 = exp(phiz1)
      return
c
      entry phiz0(n0,z0)
      n = n0
      z = z0
      phiz0 = 0.0
      return
      end
c//////////////////////////////////////////////////////////////////////////////
c Finding the +/- 1 sigma intervals on the interpolated likelihood function
c which (after normalization) is the "Fiducial Probability Function" (Kendall
c & Stuart, Vol 2, 3rd ed. p. 141)
      subroutine conf1(liklhd,t,dtm,dtp,np,pcum,imxlik,tmxlik,mxlik,
c                      i      i i   i   i  o    o      o      o
     >                 dtlikl,dtliku)
c                      o      o
      implicit none
      integer np,imxlik
      real liklhd(np),t(np),dtm(np),dtp(np),pcum(np)
      real tmxlik,mxlik,dtlikl,dtliku
      integer i
      real cn,s,p,t1sigl,t1sigu
c
      mxlik = -1.0
      do i = 1,np
         if (mxlik .lt. liklhd(i)) then
            tmxlik = t(i)
            imxlik = i
            mxlik = liklhd(i)
         endif
      enddo
      cn = 0.0
      pcum(1) = 0.0
      do i = 2,np
         cn = cn+(liklhd(i)+liklhd(i-1))/2.0*
     >           (t(i)-t(i-1))
         pcum(i) = cn
      enddo
      do i = 1,np
         pcum(i) = pcum(i)/cn
      enddo
c
      p = pcum(imxlik)+0.3413*(pcum(np)-pcum(imxlik))*2
      do i = imxlik,np
         if (pcum(i) .ge. p) then
            s = (liklhd(i)-liklhd(i-1))/(t(i)-t(i-1))
            t1sigu = t(i-1)+
     >             (-liklhd(i-1)+
     >              sqrt(liklhd(i-1)**2+2*(p-pcum(i-1))*s*cn))/s
            goto 100
         endif
      enddo
cdbg
      print *,'t1sigu = end point...'
      t1sigu = t(np)
 100  continue
c
      p = pcum(imxlik)-0.3413*(pcum(imxlik)-pcum(1))*2
      do i = imxlik,1,-1
         if (pcum(i) .le. p) then
            s = (liklhd(i+1)-liklhd(i))/(t(i+1)-t(i))
            t1sigl = t(i)+
     >             (-liklhd(i)+
     >              sqrt(liklhd(i)**2+2*(p-pcum(i))*s*cn))/s
            goto 200
         endif
      enddo
cdbg
      print *,'t1sigl = end point...'
      t1sigl = t(1)
 200  continue
c
c???      dtliku = amax0(t1sigu-tmxlik,dtp(imxlik))
c???      dtlikl = amax0(tmxlik-t1sigl,dtm(imxlik))
      dtliku = amax1(t1sigu-tmxlik,dtp(imxlik))
      dtlikl = amax1(tmxlik-t1sigl,dtm(imxlik))
cdbg
cdbg      print *,'CONF1: t1sigl = ',t1sigl,' t1sigu = ',t1sigu
cdbg
      return
      end
c///////////////////////////////////////////////////////////////////////
      SUBROUTINE QROMO1(FUNC,A,B,SS,CHOOSE)
      save all
      PARAMETER (EPS=1.E-6,JMAX=14,JMAXP=JMAX+1,KM=4,K=KM+1)
      DIMENSION S(JMAXP),H(JMAXP)
cTal(
      real*8 a,b
cTal)
      H(1)=1.
      DO 11 J=1,JMAX
        CALL CHOOSE(FUNC,A,B,S(J),J)
        IF (J.GE.K) THEN
          CALL POLIN1(H(J-KM),S(J-KM),K,0.0,SS,DSS)
cTal          IF (ABS(DSS).LT.EPS*ABS(SS)) RETURN
          IF (ABS(DSS).LE.EPS*ABS(SS)) RETURN
        ENDIF
        S(J+1)=S(J)
        H(J+1)=H(J)/9.
11    CONTINUE
      print *,'QROMO1: Too many steps...'
      END
c///////////////////////////////////////////////////////////////////////
      SUBROUTINE MIDPT1(FUNC,A,B,S,N)
cTal(
      save all
      real*8 a,b,tnm,del,ddel,x,sum
cTal)
      IF (N.EQ.1) THEN
        S=(B-A)*FUNC(0.5*(A+B))
        IT=1
      ELSE
        TNM=IT
        IF(TNM.EQ.0.)PAUSE 'MIDPT1: attempting to divide by den = 0'
        DEL=(B-A)/(3.*TNM)
        DDEL=DEL+DEL
        X=A+0.5*DEL
        SUM=0.
        DO 11 J=1,IT
          SUM=SUM+FUNC(X)
          X=X+DDEL
          SUM=SUM+FUNC(X)
          X=X+DEL
11      CONTINUE
        S=(S+(B-A)*SUM/TNM)/3.
        IT=3*IT
      ENDIF
      RETURN
      END
c//////////////////////////////////////////////////////////////////////////////
      SUBROUTINE POLIN1(XA,YA,N,X,Y,DY)
      save all
      PARAMETER (NMAX=10)
      DIMENSION XA(N),YA(N),C(NMAX),D(NMAX)
      NS=1
      DIF=ABS(X-XA(1))
      DO 11 I=1,N
        DIFT=ABS(X-XA(I))
        IF (DIFT.LT.DIF) THEN
          NS=I
          DIF=DIFT
        ENDIF
        C(I)=YA(I)
        D(I)=YA(I)
11    CONTINUE
      Y=YA(NS)
      NS=NS-1
      DO 13 M=1,N-1
        DO 12 I=1,N-M
          HO=XA(I)-X
          HP=XA(I+M)-X
          W=C(I+1)-D(I)
          DEN=HO-HP
          IF(DEN.EQ.0.)PAUSE 'POLIN1: attempting to divide by den = 0'
          DEN=W/DEN
          D(I)=HP*DEN
          C(I)=HO*DEN
12      CONTINUE
        IF (2*NS.LT.N-M)THEN
          DY=C(NS+1)
        ELSE
          DY=D(NS)
          NS=NS-1
        ENDIF
        Y=Y+DY
13    CONTINUE
      RETURN
      END
c///////////////////////////////////////////////////////////////////////
      SUBROUTINE QROMO2(FUNC,A,B,SS,CHOOSE)
      save all
cTal      PARAMETER (EPS=1.E-6,JMAX=14,JMAXP=JMAX+1,KM=4,K=KM+1)
      PARAMETER (EPS=1.E-6,JMAX=15,JMAXP=JMAX+1,KM=4,K=KM+1)
      DIMENSION S(JMAXP),H(JMAXP)
cTal(
      real*8 a,b
cTal)
      H(1)=1.
      DO 11 J=1,JMAX
        CALL CHOOSE(FUNC,A,B,S(J),J)
        IF (J.GE.K) THEN
          CALL POLIN2(H(J-KM),S(J-KM),K,0.0,SS,DSS)
cTal          IF (ABS(DSS).LT.EPS*ABS(SS)) RETURN
          IF (ABS(DSS).LE.EPS*ABS(SS)) RETURN
        ENDIF
        S(J+1)=S(J)
        H(J+1)=H(J)/9.
11    CONTINUE
      print *,'QROMO2: Too many steps...'
      END
c///////////////////////////////////////////////////////////////////////
      SUBROUTINE MIDPT2(FUNC,A,B,S,N)
cTal(
      save all
      real*8 a,b,tnm,del,ddel,x,sum
cTal)
      IF (N.EQ.1) THEN
        S=(B-A)*FUNC(0.5*(A+B))
        IT=1
      ELSE
        TNM=IT
        IF(TNM.EQ.0.)PAUSE 'MIDPT2: attempting to divide by den = 0'
        DEL=(B-A)/(3.*TNM)
        DDEL=DEL+DEL
        X=A+0.5*DEL
        SUM=0.
        DO 11 J=1,IT
          SUM=SUM+FUNC(X)
          X=X+DDEL
          SUM=SUM+FUNC(X)
          X=X+DEL
11      CONTINUE
        S=(S+(B-A)*SUM/TNM)/3.
        IT=3*IT
      ENDIF
      RETURN
      END
c//////////////////////////////////////////////////////////////////////////////
      SUBROUTINE POLIN2(XA,YA,N,X,Y,DY)
      save all
      PARAMETER (NMAX=10)
      DIMENSION XA(N),YA(N),C(NMAX),D(NMAX)
      NS=1
      DIF=ABS(X-XA(1))
      DO 11 I=1,N
        DIFT=ABS(X-XA(I))
        IF (DIFT.LT.DIF) THEN
          NS=I
          DIF=DIFT
        ENDIF
        C(I)=YA(I)
        D(I)=YA(I)
11    CONTINUE
      Y=YA(NS)
      NS=NS-1
      DO 13 M=1,N-1
        DO 12 I=1,N-M
          HO=XA(I)-X
          HP=XA(I+M)-X
          W=C(I+1)-D(I)
          DEN=HO-HP
          IF(DEN.EQ.0.)PAUSE 'POLIN2: attempting to divide by den = 0'
          DEN=W/DEN
          D(I)=HP*DEN
          C(I)=HO*DEN
12      CONTINUE
        IF (2*NS.LT.N-M)THEN
          DY=C(NS+1)
        ELSE
          DY=D(NS)
          NS=NS-1
        ENDIF
        Y=Y+DY
13    CONTINUE
      RETURN
      END
c//////////////////////////////////////////////////////////////////////////////


c---------------------------------------------------------------------
c---------------------------------------------------------------------
       pure extrinsic (hpf)
     >        subroutine l2norm ( ldx, ldy, ldz,
     >                    nx0, ny0, nz0,
     >                    ist, iend,
     >                    jst, jend,
     >                    v, summ )
      implicit none
      include 'l2norm.h'
c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   to compute the l2-norm of vector v.
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k, m

      do m = 1, 5
        summ(m) = sum(v(m,ist:iend,jst:jend,2:nz0-1)**2)
        summ(m) = sqrt ( summ(m) / ( (nx0-2)*(ny0-2)*(nz0-2) ) )
      end do

      return
      end