************************************************************************
*      polyphi - an interface to polyph
************************************************************************
*                             I/O List
*_Name______________Type______________I/O____Description________________
* drum[0:15]        LOGICAL           in     indicates drum channel(s)
* e_t[e]            REAL              in     times of events
* e_k[e]            INTEGER           in     event kinds
* e_c[e]            INTEGER           in     event channels (unused?)
* e_p1[e]           INTEGER           in     event data part 1
* e_p2[e]           INTEGER           in     event data part 2
* e_p3[e]           REAL              in     event data (duration or tempo)
* e_v[e]            INTEGER           in     note-off velocities
* e_g[e]            INTEGER           in     portamento prefixes
* e_f[e]            INTEGER           in     event source file 
* e_r[e]            INTEGER           in     event track
* e_u[e]            REAL              out    event metrical times (in tactus)
* ind[e]            INTEGER           work   permutation vector
* RSW[3@e]          Real              work   for merge sort
* JSW[3@e]          Integer           work   for merge and radix sorts
* e                 INTEGER           in     length of event list
* opt_V             Logical           in     dump NL and analysis
* score             REAL              out    total log probability
* ierr              INTEGER           out    error code
*-----------------------------------------------------------------------
      SUBROUTINE POLYPHI (drum, e_t, e_k, e_c, e_p1, e_p2, e_p3, e_v, 
     &  e_g, e_f, e_r, e_u, ind, RSW, JSW, e, opt_v, score, IERR)
      
       IMPLICIT NONE
       INTEGER e_k, e_c, e_p1, e_p2, e_v, e_g, 
     &  e_f, e_r, ind, JSW, e, ierr
       REAL e_t, e_p3, e_u, RSW, score
       LOGICAL drum, opt_v
       DIMENSION drum(0:15), e_t(e), e_k(e), e_c(e), e_p1(e), e_p2(e), 
     &  e_p3(e), e_v(e), e_g(e), e_f(e), e_r(e), e_u(e), RSW(3*e), 
     &  JSW(3*e), ind(e)

*           local variables
       INTEGER j, L,                       ! counters
     &         ioff, ion,                  ! last off, on
     &         no,                         ! Note-Ons
     &         pitch                       ! MIDI note number
     
*            constants       
       INTEGER IOU
       CHARACTER*80 fname, oname
       CHARACTER*256 cmd, line
       PARAMETER (IOU = 4)
     
*             external function
       INTEGER LTRIM             ! same as LEN_TRIM     
       
       SAVE fname, oname
       DATA fname, oname / 'file_to_analyze.notes', 'melisma2.out' /
      
************************************************************************
*   begin
************************************************************************
*            mark drum events
       DO J = 1, e
         IF (drum(e_c(J))) THEN
           IF (e_k(J) .EQ. 0 .OR. e_k(J) .EQ. 1) THEN
             e_k(J) = e_k(J) - 2    ! thus {0,1} becomes {-2,-1}
           END IF
         END IF
       END DO

*             sort note events to the front
       DO J = 1, e 
         ind(J) = J 
       END DO
       CALL RSORTI (e_k, ind, e, -7, JSW)
       CALL RORDER (e_t, ind, e)
       CALL IORDER (e_c, ind, e)
       CALL IORDER (e_p1, ind, e)
       CALL IORDER (e_p2, ind, e)
       CALL RORDER (e_p3, ind, e)
       CALL IORDER (e_v, ind, e)
       CALL IORDER (e_g, ind, e)
       CALL IORDER (e_r, ind, e)
       CALL RORDER (e_u, ind, e)
       
       CALL IBSLE(e_k, e, 0, ioff)        ! last Note-Off
       CALL IBSLE(e_k, e, 1, ion)         ! last Note-On
       no = ion - ioff                ! Note-Ons sans drums
       L = ioff + 1

*           sort Note On's by time
       DO j = 1, no 
         ind(j) = j
       END DO
       CALL MSORTR (e_t(L), ind, no, RSW, JSW)
       CALL IORDER (e_k(L), ind, no)
       CALL IORDER (e_c(L), ind, no)
       CALL IORDER (e_p1(L), ind, no)
       CALL IORDER (e_p2(L), ind, no)
       CALL RORDER (e_p3(L), ind, no)
       CALL IORDER (e_v(L), ind, no)
       CALL IORDER (e_g(L), ind, no)
       CALL IORDER (e_r(L), ind, no)
       CALL RORDER (e_u(L), ind, no)
       
************************************************************************
*          open notelist file
************************************************************************
       OPEN (FILE=fname, UNIT=IOU, STATUS='NEW', IOSTAT=IERR)
       IF (IERR .NE. 0) THEN
         PRINT *, 'polyphi:  trouble opening input file!'
         RETURN
       END IF

  10   FORMAT ('Note', I9, I9, I4)
       DO J = L, L+no-1
         ION = NINT(1000. * E_T(J))
         IOFF = NINT(1000. * (E_T(J) + E_P3(J)))
         PITCH = E_P1(J)
         WRITE (UNIT=IOU, FMT=10, IOSTAT=IERR) ION, IOFF, PITCH
         IF (opt_V) WRITE (UNIT=*, FMT=10, IOSTAT=IERR) ION, IOFF, PITCH
         IF (IERR .NE. 0) THEN
           PRINT *, 'polyphi:  trouble writing to file!'
           RETURN
         END IF
       END DO
       CLOSE (UNIT=IOU, IOSTAT=IERR)
       IF (IERR .NE. 0) PRINT *, 'polyphi:  trouble closing file!'
       
************************************************************************
*                  Call program MELISMA2
************************************************************************
       L = LTRIM(fname)
       cmd = 'polyph ' // fname(1:L) // ' > ' // oname
!!       PRINT *, 'using command ', CMD
       CALL SYSTEM (cmd)

************************************************************************
*                   Retrieve results
************************************************************************
       OPEN (FILE=oname, UNIT=IOU, STATUS='OLD', IOSTAT=IERR)
       IF (IERR .NE. 0) THEN
         PRINT *, 'polyphi:  trouble opening results file!'
         RETURN
       END IF
       
       DO 30 WHILE (.TRUE.)
  20     FORMAT (A)     
         READ (UNIT=IOU, FMT=20, END=40, IOSTAT=IERR) LINE
         IF (opt_v) WRITE (UNIT=*, FMT=20) LINE
         IF (IERR .NE. 0) PRINT *, 'polyphi:  trouble reading results!'
         J = INDEX(LINE, 'Total final score =')
!!!         PRINT *, 'read line: ', LINE, ' index returns: ', J
         IF (J .EQ. 0) GO TO 30
         L = LTRIM(LINE)
!!!         PRINT *, 'attempting to interpret: ', LINE(20:L)
         READ (UNIT=LINE(20:L), FMT=*, IOSTAT=IERR) SCORE
         GO TO 40
  30    END DO
  40   CLOSE (UNIT=IOU, IOSTAT=IERR)
       IF (IERR .NE. 0) PRINT *, 
     &                'polyphi:  trouble closing results file!'

*                delete work files
       CALL UNLINK (fname, ierr)
       IF (ierr .NE. 0) PRINT *, 'trouble deleting ', fname
       CALL UNLINK (oname, ierr)
       IF (ierr .NE. 0) PRINT *, 'trouble deleting ', oname      

       RETURN  ! success
      END
      