*-----------------------------------------------------------------------
* midifile.f - transfer symbolic musical data to and from the MIDI file format
* by Andy Allinger, 2012-2015, released to the public domain
* This program may be used by any person for any purpose.
*----------------------------------------------------------------------- 


*----------------------------------------------------------------------- 
*                             EVENT KINDS
*----------------------------------------------------------------------- 
*
*_Kind___Description_______________Par._1____Par._2____Par._3____MIDI_#_
*  0     Note Off                  Note #    Velocity             8
*  1     Note On                                                  9
*
*------------------------- Note on parameters --------------------------
*   Integer  e_p1  Note #             [0,127]      
*   Integer  e_p2  Velocity           [128,16383]  supporting hi-res velocity
*   Real     e_p3  Duration           in seconds
*   Integer  e_g   Portamento prefix  [0,127]
*   Integer  e_v   OFF-velocity       [0,16383]    note-off also has hi-res
*-----------------------------------------------------------------------
*
*_Kind___Description_______________Par._1____Par._2____Par._3____MIDI_#_
*  2     Aftertouch (polyphonic)   Note #    [0,127]             10
*  3     Bank Select               14 bits   {0,1,2}             11-0, 11-32
*                                             0 = fine only 
*                                             1 = coarse only
*                                             2 = both
*  4     Wheel                     14 bits   {0,1,2}             11-1, 11-33
*  5     Breath                    14 bits   {0,1,2}             11-2, 11-34
*  6     Foot                      14 bits   {0,1,2}             11-4, 11-36
*  7     Portamento Rate           14 bits   {0,1,2}             11-5, 11-37
*  8     Data Entry                14 bits   {0,1,2}             11-6, 11-38
*  9     Volume                    14 bits   {0,1,2}             11-7, 11-39
* 10     Balance                   14 bits   {0,1,2}             11-8, 11-40
* 11     Pan                       14 bits   {0,1,2}             11-10, 11-42
* 12     Expression                14 bits   {0,1,2}             11-11, 11-43
* 13     Effect Control #1         14 bits   {0,1,2}             11-12, 11-44
* 14     Effect Control #2         14 bits   {0,1,2}             11-13, 11-45
* 15     General Purpose #1        14 bits   {0,1,2}             11-16, 11-48
* 16     General Purpose #2        14 bits   {0,1,2}             11-17, 11-49
* 17     General Purpose #3        14 bits   {0,1,2}             11-18, 11-50
* 18     General Purpose #4        14 bits   {0,1,2}             11-19, 11-51
* 19     Sustain Pedal             {0,127}                       11-64
* 20     Portamento Pedal          {0,127}                       11-65
* 21     Sostenuto Pedal           {0,127}                       11-66
* 22     Soft Pedal                {0,127}                       11-67
* 23     Legato Pedal              {0,127}                       11-68
* 24     Hold 2                    {0,127}                       11-69
* 25     Sound Variation           7 bits                        11-70
* 26     Filter Resonance          7 bits                        11-71
* 27     Release Time              7 bits                        11-72
* 28     Attack Time               7 bits                        11-73
* 29     Brightness                7 bits                        11-74
* 30     Decay Time                7 bits                        11-75
* 31     Vibrato Rate              7 bits                        11-76
* 32     Vibrato Depth             7 bits                        11-77
* 33     Vibrato Delay             7 bits                        11-78
* 34     Sound Control #10         7 bits                        11-79
* 35     General Purpose #5        7 bits                        11-80
* 36     General Purpose #6        7 bits                        11-81
* 37     General Purpose #7        7 bits                        11-82
* 38     General Purpose #8        7 bits                        11-83
* 39     Portamento Control        Note #                        11-84
* 40     Hi-Resolution Velocity    7 bits                        11-88
* 41     Reverb                    7 bits                        11-91
* 42     Tremolo Depth             7 bits                        11-92
* 43     Chorus Depth              7 bits                        11-93
* 44     Celeste/Detune Depth      7 bits                        11-94
* 45     Phaser Depth              7 bits                        11-95
* 46     Data Increment            +1                            11-96
*        Data Decrement            -1                            11-97
* 47     Non-Registered Par #      NRPN #    14 bit value        11-99, 11-98
* 48     Registered Parameter #    RPN #                         11-101, 11-100
* 49     All Sound Off                                           11-120
* 50     All Controllers Off                                     11-121
* 51     Local Control             {0,127}                       11-122
* 52     All Notes Off                                           11-123
* 53     Omni Off / On             {0,127}                       11-124, 11-125
* 54     Mono / Poly               {0,127}   [0,16]              11-126, 11-127
* 55     Patch Change              Patch #                       12
* 56     Aftertouch (channel)      7 bits                        13
* 57     Pitch Bend                14 bits                       14
* 58     System Exclusive          Pointer   Length              15-0
* 59     Continued SysEx           Pointer   Length              15-7
* 60     Sequence #                16 bits                       15-15-0
* 61     Text                      Pointer   Length              15-15-1
* 62     Copyright                 Pointer   Length              15-15-2
* 63     Sequence Name             Pointer   Length              15-15-3
* 64     Instrument Name           Pointer   Length              15-15-4
* 65     Lyric                     Pointer   Length              15-15-5
* 66     Marker                    Pointer   Length              15-15-6
* 67     Cue Point                 Pointer   Length              15-15-7
* 68     Patch Name                Pointer   Length              15-15-8
* 69     Port Name                 Pointer   Length              15-15-9
* 70     Tempo                                         Hertz     15-15-81
* 71     SMPTE Offset                                  Seconds   15-15-84
* 72     Time Signature            Numerator LOG2(Denominator)   15-15-88
* 73     Key Signature             # Sharps  {0,1}               15-15-89
*                                             0 = major key
*                                             1 = minor key
* 74     XMF Patch Type            {1,2,3}                       15-15-96
* 75     Sequencer Specific        Pointer   Length              15-15-127
* 76     Pitch Bend Range          Cents                         RPN 0
* 77     Fine Tuning               14 bits                       RPN 1
* 78     Coarse Tuning             7 bits                        RPN 2
* 79     Tuning Program            7 bits                        RPN 3
* 80     Tuning Bank               7 bits                        RPN 4
* 81     Modulation Depth Range    14 bits                       RPN 5
* 82     Azimuth Angle             14 bits                       RPN 7808
* 83     Elevation Angle           14 bits                       RPN 7809
* 84     Gain                      14 bits                       RPN 7810
* 85     Distance Ratio            14 bits                       RPN 7811
* 86     Maximum Distance          14 bits                       RPN 7812
* 87     Gain at Max Dist          14 bits                       RPN 7813
* 88     Reference Distance Ratio  14 bits                       RPN 7814
* 89     Pan Spread Angle          14 bits                       RPN 7815
* 90     Roll Angle                14 bits                       RPN 7816
* 99     Non-Event                                                   
*
* Not specifically represented:    
*     Channel prefix   15-15-32    Channel is stored for each meta-event
*     End of Track     15-15-47    Number of events stored instead
*-----------------------------------------------------------------------


*-----------------------------------------------------------------------
*  CMIDI - First phase of interpreting a Midi file.  Count the number of 
*    schedule events (tempo change, key change, time signature change) that 
*    are to be represented, the number of text strings associated to meta 
*    events, and the number of channel events to be represented.  Ignored 
*    events are not counted.
*-----------------------------------------------------------------------
*                              I/O LIST
*  Name            Type            I/O       Description
*  buf[Ltot]       INTEGER*1       in        contents of the files
*  f_name[n_file]  CHARACTER*256   in        files to be parsed
*  L_file[n_file]  INTEGER         in        length in bytes of each file
*  Ltot            INTEGER         in        combined file length
*  n_file          INTEGER         in        the number of files
*  mnn             INTEGER         out       maximum number of NoteOn's
*  mnr             INTEGER         out       maximum number of tracks
*  nb              INTEGER         out       number of blob events
*  n_trk[n_file]   INTEGER         work      number of tracks each file
*  bt[n_file]      LOGICAL         out       a tempo event needed at time 0
*  bs[n_file]      LOGICAL         out       a time signature needed at t=0
*  bk[n_file]      LOGICAL         out       a key signature needed at t=0
*  etot            INTEGER         out       count of all events
*  fault           INTEGER         out       error code 0 = no errors
*                                                      >0 = input error
*                                                      -1 = internal error
*-----------------------------------------------------------------------
      SUBROUTINE CMIDI(buf, f_name, L_file, Ltot, n_file, 
     & mnn, mnr, nb, n_trk, bt, bs, bk, etot, fault)
      
       IMPLICIT NONE
       INTEGER L_file, Ltot, n_file, mnn, mnr, nb,
     &  n_trk, etot, fault
       LOGICAL bt, bs, bk
       INTEGER*1 buf
       CHARACTER*256 f_name
       DIMENSION buf(Ltot), f_name(n_file), L_file(n_file), 
     &  n_trk(n_file),
     & bt(n_file), bs(n_file), bk(n_file)
               
*         local variables
       INTEGER n_ctl 
       PARAMETER (n_ctl=73)
       INTEGER*1 
     &           b, c,                ! single bytes
     &           mthd(4),             ! file header constant
     &           mtrk(4),             ! track header constant
     &           varb(4)
     
       INTEGER
     &           ctlnum(n_ctl),        ! recognized controllers
     &           f,                    ! cumulative file length (buffer offset)
     &           f_type,               ! midi file type {0, 1, 2}
     &           h,                    ! counter
     &           i,                    ! file position
     &           IOU,                  ! file I/O Unit
     &           j,                    ! count tracks
     &           k,                    ! count files
     &           L,                    ! Length of a file
     &           m,                    ! temporary integer
     &           meta,                 ! which kind of meta event
     &           n                     ! length of track data
       INTEGER
     &           n_note,               ! number of NoteOn's in a file
     &           o,                    ! count position into track data
     &           p,                    ! number of data bytes in an event
     &           runch,                ! running status channel
     &           runk,                 ! running status event kind
     &           RVARB,                ! external function
     &           newk, newch,          ! current event kind and channel
     &           z                     ! declared length of a track or header
     
       LOGICAL atbegin,                 ! no delta-time has elapsed in track
     &         skip                     ! present chunk is to be skipped
     
*                     external functions
       INTEGER LTRIM, IOUNIT
       
       SAVE ctlnum, mthd, mtrk
       DATA ctlnum /  0,  1,  2,  4,  5,  6,  7,  8, 10, 11, 12, 13,
     &               16, 17, 18, 19, 32, 33, 34, 36, 37, 38, 39, 40,
     &               42, 43, 44, 45, 48, 49, 50, 51, 64, 65, 66, 67, 
     &               68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 
     &               80, 81, 82, 83, 84, 88, 91, 92, 93, 94, 95, 96,
     &               97, 98, 99,100,101,120,121,122,123,124,125,126,
     &               127 /
     
       DATA mthd / 77, 84, 104, 100 /
       DATA mtrk / 77, 84, 114, 107 /
     
*-----------------------------------------------------------------------
*        begin
*-----------------------------------------------------------------------
       f = 0
       fault = 0
       mnn = 0
       nb = 0
       etot = 0

*         for each file
       DO k = 1, n_file
         L = L_file(k)
         IF (L < 14) THEN
           fault = 1
           print *, 'too short of a MIDI file'
           RETURN
         END IF
         
*           file I/O
         IOU = IOUNIT()
         OPEN (UNIT=IOU, FILE=f_name(k), ACCESS='DIRECT', RECL=1, 
     &     FORM='UNFORMATTED', IOSTAT=fault)
         IF (fault .NE. 0) PRINT *, 'trouble opening file ', f_name(k)
         DO i = 1, L
           READ (UNIT=IOU, REC=i, IOSTAT=fault) buf(f+i)
           IF (fault .NE. 0) 
     &       PRINT *, 'trouble reading from', f_name(k), ' position ', i
         END DO
         CLOSE (UNIT=IOU)
         
*          check for the MIDI file header
         DO h = 1, 4
           IF (buf(f+h) .NE. mthd(h)) THEN
             L = LTRIM(f_name(k)) 
             PRINT '(A, A)', f_name(k)(1:L), ': not a MIDI file'
             fault = 2
             RETURN
           END IF
         END DO
         
*          read the declared length
         z = 0
         DO h = 1, 4
           CALL BYTGET(buf(f+4+h), z, 4-h)
         END DO
         IF (z .NE. 6) THEN
           PRINT *, 'CMIDI: header length: ', z, ' expected 6'
         END IF
         
*          MIDI file type/format
         m = 0                             
         CALL BYTGET(buf(f+9), m, 1)       ! new sub to copy bits
         CALL BYTGET(buf(f+10), m, 0)
         IF ( (m .EQ. 0) .OR. (m .EQ. 1) .OR. (m .EQ. 2) ) THEN
           f_type = m
         ELSE 
           PRINT *, f_name(k), ' unrecognized SMF format'
           f_type = 1               ! default 
         END IF

*          number of tracks
         m = 0
         CALL BYTGET(buf(f+11), m, 1)
         CALL BYTGET(buf(f+12), m, 0)
         IF (m > 0 .AND. m < 65536) THEN
           n_trk(k) = m
         ELSE
           PRINT *, f_name(k), ' # tracks out of bounds:  ', m
           FAULT = 3
           RETURN
         END IF

*             files with multiple tracks are not type 0, fix
         IF (f_type .EQ. 0 .AND. n_trk(k) .NE. 1) THEN
           PRINT *, 'warning: ', f_name(k), ' is not Type 0'
           fault = 52
           f_type = 1
         END IF
                  
*          time division
         n = 0
         CALL BYTGET(buf(f+13), n, 1)
         CALL BYTGET(buf(f+14), n, 0)
         IF (BTEST(n, 15)) THEN

*             SMPTE timing
           m = IBITS(n, 8, 7)
           IF ( (m .EQ. 98) .OR. (m .EQ. 99) 
     &          .OR. (m .EQ. 103) .OR. (m .EQ. 104) ) THEN
             CONTINUE                ! convert to a second-per-tick value later
           ELSE
             PRINT *, f_name(k), ':  bad frame per second value!'
             fault = 3
             RETURN
           END IF

           m = IBITS(n, 0, 8)         ! ticks-per-frame
           IF (m .EQ. 0) THEN
             PRINT *, f_name(k), ':  0 ticks per frame!'
             fault = 4
             RETURN
           END IF
           
*              tempo-based timing
         ELSE 
           m = IBITS(n, 0, 15)
           IF (m .EQ. 0) THEN
             PRINT *, f_name(k), ': 0 time division!'
             fault = 5
             RETURN
           END IF
         END IF       ! which timing method
         
*          start fresh counts
         n_note = 0
         bt(k) = .TRUE.    ! initial values must be defined
         bs(k) = .TRUE.
         bk(k) = .TRUE.
         i = 8 + z          ! permitting lengths other than 6
         
*-----------------------------------------------------------------------
*            for each track
*-----------------------------------------------------------------------
         DO 50 j = 1, n_trk(k)
  
*             check the track header
           IF (L < i+8) THEN
             PRINT *, f_name(k), ': track ', j, ' missing'
             fault = 6
             RETURN
           END IF
           
           IF (f+i+4 > Ltot) THEN         ! avoid overrun
             PRINT *, 'cmidi: attempted buffer overrun!'
             PRINT *, 'cmidi: unable to read ', f_name(k)
             fault = 47
             RETURN
           END IF

           skip = .FALSE.
           DO h = 1, 4
             i = i + 1
             IF (buf(f+i) .NE. mtrk(h)) skip = .TRUE.
           END DO
           IF (skip) PRINT *, f_name(k), ': unrecognized chunk! '
           
*            track length
           n = 0
           CALL BYTGET(buf(f+i+1), n, 3)
           CALL BYTGET(buf(f+i+2), n, 2)
           CALL BYTGET(buf(f+i+3), n, 1)
           CALL BYTGET(buf(f+i+4), n, 0)
           i = i + 4
           
*                 skip unrecognized chunks
           IF (skip) THEN
             i = i + n           
             GO TO 50
           END IF
           
*-----------------------------------------------------------------------
*            negative p       next byte is status
*            zero p           next byte is delta-time
*            positive p       next byte is data           
*-----------------------------------------------------------------------
           atbegin = .TRUE.
           runk = -1           ! no running status
           runch = -1
           o = 0
           p = 0

*              check track length
           IF (i+n > L) THEN
             PRINT *, f_name(k), ': track ', j, ' longer than file'
             fault = 7
             RETURN
           END IF
           
*-----------------------------------------------------------------------
*             process the track
*-----------------------------------------------------------------------
           DO 40 WHILE (o < n)
             i = i + 1 
             o = o + 1
             IF (p) 10, 20, 30
             
*-----------------------------------------------------------------------
  10         CONTINUE           !        status byte
*-----------------------------------------------------------------------
             b = buf(f+i)
             IF (BTEST(b, 7)) THEN            ! status byte present
               newk = IBITS(b, 4, 4)           ! new event kind
               newch = IBITS(b, 0, 4)           ! new event channel
               IF (newk .GE. 8 .AND. newk .LE. 14) THEN  ! store running status
                 runk = newk
                 runch = newch
               END IF             

             ELSE                         ! no status byte
               i = i - 1                   ! back up
               o = o - 1
               newk = runk                ! retrieve from running status
               newch = runch
             END IF
             
*                Note-Off
             IF (newk .EQ. 8) THEN
               p = 2              ! two bytes to follow
               etot = etot + 1
               
*               Note-On
             ELSE IF (newk .EQ. 9) THEN               
               p = 2              ! two bytes to follow
               IF (o + 1 .GE. n) THEN
                 PRINT *, f_name(k), ': track data exhausted'
                 GO TO 50  ! next track
               END IF
               IF (buf(f+i+2) .EQ. 0) THEN 
                 etot = etot + 1                ! actually a Note-Off
               ELSE
                 n_note = n_note + 1              ! count real Note-Ons
                 etot = etot + 2                  ! count double (worst case)
               END IF

*                aftertouch
             ELSE IF (newk .EQ. 10) THEN
               p = 2              ! two bytes to follow
               etot = etot + 1
             
*                 controllers
             ELSE IF (newk .EQ. 11) THEN
               p = 2
               IF (o .GE. n) THEN
                 PRINT *, f_name(k), ': track data exhausted'
                 fault = 18
                 GO TO 50  ! next track
               END IF
               c = buf(f+i+1)
               
*                   is this controller in the recognized list?               
               m = 0
               CALL BYTGET (c, m, 0)
               CALL IBSLE (ctlnum, n_ctl, m, h)
               IF (h < 1) THEN
                 PRINT *, 'CMIDI: bad controller index!'
                 fault = -4
                 RETURN
               END IF
               
               IF (m .EQ. ctlnum(h)) THEN
                 etot = etot + 1
               ELSE
!!                  PRINT *, 'CMIDI: unrecognized controller ', m
                 CONTINUE  ! and don't complain
               END IF

*                 patch change
             ELSE IF (newk .EQ. 12) THEN
               p = 1            ! one byte to follow
               etot = etot + 1
               IF (o .GE. n) THEN
                 PRINT *, f_name(k), ': track data exhausted'
                 GO TO 50
               END IF

*              channel pressure
             ELSE IF (newk .EQ. 13) THEN  
               p = 1            ! one byte to follow
               etot = etot + 1

*                 pitch bend
             ELSE IF (newk .EQ. 14) THEN
               p = 2
               etot = etot + 1
               
*-----------------------------------------------------------------------
*                Meta and SysEx
* NOTE:  The MIDI spec says that a Meta event cancels any running status.
* Some files carry running status across a meta event.  Since timidity
* and mftext can handle these files, the same will be done here, for
* de facto standards compatibility.
*-----------------------------------------------------------------------
             ELSE IF (newk .EQ. 15) THEN
               IF (newch .EQ. 0 .OR. newch .EQ. 7) THEN
                 etot = etot + 1
                 nb = nb + 1
*                       offset of i added in declen!
                 CALL declen(buf(f+1), varb, i, o, L, n, p)   

               ELSE IF (newch .EQ. 15) THEN          ! meta event
                 i = i + 1 
                 o = o + 1
                 meta = 0
                 CALL BYTGET(buf(f+i), meta, 0)

*                    meta events with blobs                 
                 IF ( (meta .GE. 1 .AND. meta .LE. 9)
     &                 .OR. meta .EQ. 127 )   nb = nb + 1

*                     optional events
                 IF (meta < 10 .OR. 
     &                   meta .EQ. 96 .OR. meta .EQ. 127) THEN
                   etot = etot + 1

*                      end of track
                 ELSE IF (meta .EQ. 47) THEN
                   IF (o .NE. n-1) THEN
                     PRINT *, f_name(k), ': end of track at ', o
                     fault = 1
                   END IF
                   i = i + 1 
                   o = o + 1
                   GO TO 50     ! next track
                 END IF

*                    schedule events 
                 IF (meta .EQ. 81) THEN
                   etot = etot + 1
                   IF (atbegin) bt(k) = .FALSE.
                 ELSE IF (meta .EQ. 84) THEN
                   etot = etot + 1
                 ELSE IF (meta .EQ. 88) THEN
                   etot = etot + 1
                   IF (atbegin) bs(k) = .FALSE.
                 ELSE IF (meta .EQ. 89) THEN
                   etot = etot + 1
                   IF (atbegin) bk(k) = .FALSE.
                 END IF
                 
*                      decode length of the meta-event
                 CALL declen(buf(f+1), varb, i, o, L, n, p)
                                           
*                   unrecognized status byte 0XF?
               ELSE
                 PRINT *,f_name(k),' at ',i,' realtime/unrecognized', b
               END IF   ! meta or sysex?
                
*                bad status value
             ELSE
               PRINT *, 'invalid running status value'
               runk = 9 
               runch = 0 
             END IF
             
!             PRINT *, 'event ', etot, ' is kind ', newk

             GO TO 40     ! back to the top of the WHILE loop

*-----------------------------------------------------------------------
  20         CONTINUE                !  read in a delta-time
*-----------------------------------------------------------------------
             IF (o > n-3) THEN
               PRINT *, 'premature end of track!'
               PRINT *, 'file ',K,' track ',J,' offset ',O,' of ',N
               FAULT = 8
               RETURN
             END IF
             
             m = RVARB(p, buf(f+i))      ! roles of m and p are different here
             IF (m > 0) atbegin = .FALSE.
             i = i + p - 1 
             o = o + p - 1      ! advance pointer
             p = -1
             GO TO 40                 ! look for a status byte
             
*-----------------------------------------------------------------------
  30         CONTINUE                ! skip through data bytes
*-----------------------------------------------------------------------
             p = p - 1
             
  40       CONTINUE  ! buffer position loop
  
  50     CONTINUE ! per-track loop

         f = f + L
         mnn = MAX(mnn, n_note)         
       END DO ! per-file loop
       
*             find maxima
       mnr = n_trk(1)
       DO k = 2, n_file
         mnr = MAX(mnr, n_trk(k))
       END DO       
       RETURN
      END ! of CMIDI


*-----------------------------------------------------------------------
*  RMIDI - Read a set of Midi files into the internal data structure
*-----------------------------------------------------------------------
*                              I/O LIST
*__Name_________________Type___________I/O____Description_______________
*  buf[Ltot]            INTEGER*1      in     all the files
*  f_name[n_file]       CHARACTER*256  in     files to be parsed
*  L_file[n_file]       INTEGER        in     length in bytes of each file
*  Ltot                 INTEGER        in     combined file length
*  n_file               INTEGER        in     the number of files
*  opt_b                LOGICAL        in     synchronize beginning time
*  opt_f                LOGICAL        in     synchronize final time
*  opt_N                LOGICAL        in     permit overlapping notes
*  mnr                  INTEGER        in     maximum number of tracks
*  bt[n_file]           LOGICAL        in     a tempo event needed at time 0
*  bs[n_file]           LOGICAL        in     a time signature needed at t=0
*  bk[n_file]           LOGICAL        in     a key signature needed at t=0
*  etot                 INTEGER        in     count of all events
*  kul                  INTEGER        out    max of any kind in any track
*  kuse[n_kind,mnr]     INTEGER        work   count of usage each event kind
*  n_trk[n_file]        INTEGER        out    # tracks in each file
*  e_s[etot],           INTEGER        work   event time in cumulative ticks
*  e_t[etot]            REAL           out    event times [seconds]
*  e_k[etot]            INTEGER        out    event kind 
*  e_c[etot]            INTEGER        out    event channel
*  e_p1[etot]           INTEGER        out    event parameter 1
*  e_p2[etot]           INTEGER        out    event parameter 2
*  e_p3[etot]           REAL           out    event parameter 3
*  e_v[etot]            INTEGER        out    note off velocities
*  e_g[etot]            INTEGER        out    note portamento prefixes
*  e_f[etot]            INTEGER        out    event original files
*  e_r[etot]            INTEGER        out    event original tracks
*  e_u[etot]            REAL           out    event metrical times
*  ind[etot]            INTEGER        work   index array
*  JSW[2*etot]          INTEGER        work   for radix sorting
*  tf                   REAL           out    time of last event, overall
*  tend[n_file]         REAL           out    time of last event each file
*  eact                 INTEGER        out    num events actually returned
*  usehrv               LOGICAL        out    hi-res velocity in use
*  psi[0:127,0:15]      INTEGER        work   pointer to sound inception
*  fault                INTEGER        out    error code 0=no errors
*
*-----------------------------------------------------------------------
      SUBROUTINE RMIDI (buf, f_name, L_file, Ltot, n_file, 
     &  opt_b, opt_f, opt_N, mnr, bt, bs, bk,
     &  etot, kul, kuse, n_trk, e_s, e_t, e_k, e_c, e_p1, e_p2, 
     &  e_p3, e_v, e_g, e_f, e_r, e_u, ind, JSW,
     &  tf, tend, eact, usehrv, psi, fault)
      
       IMPLICIT NONE
       INTEGER L_file, Ltot, n_file, mnr,  
     &  etot, kul, kuse, n_trk, 
     &  e_s, e_k, e_c, e_p1, e_p2, e_v, e_g, e_f, e_r, ind, JSW, 
     &  eact, psi, fault
       REAL e_t, e_p3, e_u, tf, tend
       LOGICAL opt_b, opt_f, opt_N, bt, bs, bk, usehrv
       INTEGER*1 buf
       CHARACTER*256 f_name
       INTEGER n_kind
       PARAMETER (n_kind = 90)
       DIMENSION buf(Ltot), f_name(n_file), L_file(n_file),  
     &  bt(n_file), bs(n_file), bk(n_file), kuse(n_kind,mnr),
     &  n_trk(n_file),
     &  e_s(etot), e_t(etot), e_k(etot), 
     &  e_c(etot), e_p1(etot), e_p2(etot), e_p3(etot), 
     &  e_v(etot), e_g(etot), e_f(etot), e_r(etot), 
     &  e_u(etot), ind(etot), JSW(2*etot), tend(n_file), psi(0:127,0:15)
               
*         local variables
       INTEGER n_ctl, n_fin
       PARAMETER (n_ctl=73, n_fin=16)
       INTEGER*1 
     &           b, c,                 ! single bytes
     &           mtrk(4),              ! track header
     &           varb(4)
     
       INTEGER
     &           BITSZ,                ! same as BIT_SIZE
     &           chan,                 ! a channel
     &           div,                  ! timing resolution, ticks per Q.N.
     &           f_type,               ! midi file type {0,1,2}
     &           spar(31,0:15),        ! saved parameters
     &           ctlfin(n_fin),        ! recognized fine-adjust controllers
     &           ctlnum(n_ctl),        ! recognized controllers
     &           f,                    ! cumulative length of files
     &           g, gg,                ! count events and tacked-on events
     &           h,                    ! misc. counter
     &           hrv(0:15),            ! high-resolution velocity, each chan
     &           i                     ! file position
       INTEGER
     &           j,                    ! count tracks
     &           k,                    ! count files
     &           kind,                 ! an event kind
     &           L,                    ! Length of a file
     &           m,                    ! temporary integer
     &           meta,                 ! which kind of meta event
     &           n,                    ! length of track data
     &           newch, newk           ! current status event kind and channel
       INTEGER 
     &           note,                 ! a note #
     &           nrpn(0:15),           ! non-registered parameter number
     &           o,                    ! count position into track data
     &           p,                    ! number of data bytes in an event
     &           prtm(0:15),           ! portamento prefix, each channel
     &           prefix,               ! the channel prefix for meta events
     &           r,                    ! index of first event for a file
     &           rpn(0:15),            ! registered parameter number
     &           s, sprev,             ! ticks elapsed so far
     &           prev_ctl,             ! previous controller used
     &           runch,                ! running status channel
     &           runk,                 ! running status event kind
     &           RVARB,                ! external function
     &           tpf,                  ! ticks per frame
     &           vel,                  ! a velocity
     &           z                     ! declared length of file header
     
       REAL
     &      bps,                          ! tempo, beats per second
     &      dt,                           ! a time step
     &      factor,                       ! ratio of average tend to tend
     &      fps,                          ! frames per second
     &      offset,                       ! offset time [s]
     &      rdiv,                         ! 1/time division as REAL
     &      spt,                          ! seconds per tick
     &      t,                            ! elapsed time
     &      u                             ! elapsed metrical time
   
       LOGICAL
     &          donset,           ! done an SMPTE offset for this file?
     &          donxmf,           ! done an XMF prefix for this track?
     &          isfin,            ! process a LSB controller
     &          isrec,            ! controller in recognized list
     &          skip,             ! skip a whole chunk
     &          smpte,            ! what kind of timing
     &          reg               ! registered vs. non-registered
    
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!    
!         INTEGER gprev
         
       SAVE ctlfin, ctlnum, mtrk
       DATA ctlfin / 32, 33, 34, 36, 37, 38, 39, 40, 42, 43, 44, 45,
     &               48, 49, 50, 51 /
       DATA ctlnum /  0,  1,  2,  4,  5,  6,  7,  8, 10, 11, 12, 13,
     &               16, 17, 18, 19, 32, 33, 34, 36, 37, 38, 39, 40,
     &               42, 43, 44, 45, 48, 49, 50, 51, 64, 65, 66, 67, 
     &               68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 
     &               80, 81, 82, 83, 84, 88, 91, 92, 93, 94, 95, 96,
     &               97, 98, 99,100,101,120,121,122,123,124,125,126,
     &               127 /
       DATA mtrk / 77, 84, 114, 107 /

*-----------------------------------------------------------------------
*        begin
*-----------------------------------------------------------------------
       fault = 0
       f = 0                          ! no bytes read
       g = 0                          ! no events stored
       kul = 0                              ! no events yet
       usehrv = .FALSE.                     ! no hi-res velocity events
       div = 120
       fps = 29.97
       s = 0
       
*               clear event kind count
       DO j = 1, mnr
         DO h = 1, n_kind 
           kuse(h,j) = 0 
         END DO           
       END DO
           
*         for each file
       DO k = 1, n_file
         L = L_file(k)
         IF (L < 14) THEN
           PRINT *, 'too short of a MIDI file'
           fault = 10
           RETURN
         END IF
         
*          read the declared length
         z = 0
         DO h = 1, 4
           CALL BYTGET(buf(f+4+h), z, 4-h)
         END DO
         IF (z .NE. 6) THEN
           PRINT *, 'RMIDI: header length: ', z, ' expected 6'
           CONTINUE
!!           fault = 35
         END IF

*          MIDI file type/format
         m = 0
         CALL BYTGET(buf(f+9), m, 1)
         CALL BYTGET(buf(f+10), m, 0)         
         IF ( (m .EQ. 0) .OR. (m .EQ. 1) .OR. (m .EQ. 2) ) THEN
           f_type = m
         ELSE 
           PRINT *, f_name(k), ' unrecognized SMF format'
           f_type = 1             ! why not
         END IF

*          number of tracks
         m = 0
         CALL BYTGET(buf(f+11), m, 1)
         CALL BYTGET(buf(f+12), m, 0)
         IF (m > 0 .AND. m < 65536) THEN
           n_trk(k) = m
         ELSE
           PRINT *, f_name(k), ' # tracks out of bounds:  ', m
           fault = 11
           RETURN
         END IF

*             check the 1-track limit for Type 0 files
         IF (f_type .EQ. 0 .AND. n_trk(k) .NE. 1) THEN
           PRINT *, 'warning: ', f_name(k), ' is not Type 0'
           f_type = 1
           fault = 1
         END IF
                  
*          time division
         n = 0
         CALL BYTGET(buf(f+13), n, 1)
         CALL BYTGET(buf(f+14), n, 0)
         IF (BTEST(n, 15)) THEN             !  SMPTE timing
           smpte = .TRUE.
           m = IBITS(n, 8, 7)              ! frames per second

*              frames per second is stored as a NEGATIVE number
*                          why ask why?
           IF (m .EQ. 98) THEN     ! 2's complement of 30 for a 7-bit integer
             fps = 30.
           ELSE IF (m .EQ. 99) THEN
             fps = 29.97
           ELSE IF (m .EQ. 103) THEN
             fps = 25.
           ELSE IF (m .EQ. 104) THEN
             fps = 24.
           ELSE
             print *, 'bad frame per second value!'
             FAULT = 12
             RETURN
           END IF

           tpf = IBITS(n, 0, 8)         ! ticks per frame
           IF (tpf .EQ. 0) THEN
             PRINT *, ' 0 ticks per frame!'
             fault = 13
             RETURN
           END IF
           spt = 1. / (tpf * fps)            ! seconds per tick
           
*            tempo-based timing
         ELSE 
           smpte = .FALSE.
           m = IBITS(n, 0, 15)
           IF (m .EQ. 0) THEN
             PRINT *, ' 0 time division!'
             fault = 14
             RETURN
           END IF
           div = m                           ! ticks per quarter note
           spt = 0.5 / FLOAT(div)             ! beginning tempo 120 bpm
           
!!!!!!!!!!!!!! debugging
           IF (spt .NE. spt) THEN
             PRINT *, 'rmidi: NaN seconds per tick!'
             PRINT *, 'div was ', DIV, ' float(div): ', FLOAT(div)
             STOP
           END IF
           
         END IF       ! which timing method
         
*             index of where this file's events begin
         r = g + 1
         donset = .FALSE.          ! no SMPTE offset

*               default events
         IF (bt(k)) THEN
           g = g + 1
           e_s(g) = 0
           e_k(g) = 70              ! tempo
           e_c(g) = 0
           e_p1(g) = 500000          ! microseconds per quarter note
           e_p3(g) = 2.0              ! cycles per second [Hz]
           e_r(g) = 1                  ! track one
           e_f(g) = k
           e_v(g) = 0
           e_g(g) = -1
           kuse(70,1) = kuse(70,1) + 1
         END IF
         
         IF (bs(k)) THEN
           g = g + 1
           e_s(g) = 0
           e_k(g) = 72              ! time signature
           e_c(g) = 0
           e_p1(g) = 4              ! 4/4
           e_p2(g) = 2      
           e_r(g) = 1
           e_f(g) = k
           e_v(g) = 0
           e_g(g) = -1
           kuse(72,1) = kuse(72,1) + 1
         END IF
         
         IF (bk(k)) THEN
           g = g + 1
           e_s(g) = 0
           e_k(g) = 73            ! key signature
           e_c(g) = 0
           e_p1(g) = 0             ! C major
           e_p2(g) = 0
           e_r(g) = 1
           e_f(g) = k
           e_v(g) = 0
           e_g(g) = -1
           kuse(73,1) = kuse(73,1) + 1
         END IF
         
         i = 8 + z

*            for each track
         DO 50 j = 1, n_trk(k)
           donxmf = .FALSE.           ! permit 1 XMF prefix per track
           prefix = -1                ! clear channel prefix
         
           IF (f+i+4 > Ltot) THEN         ! avoid overrun
             PRINT *, 'rmidi: attempted buffer overrun!'
             fault = 47
             RETURN
           END IF
           
           skip = .FALSE.
           DO h = 1, 4
             IF (buf(f+i+h) .NE. mtrk(h)) skip = .TRUE.
           END DO
           IF (skip) PRINT *, 'RMIDI: unrecognized chunk'
           i = i + 4   
           
*            track length
           n = 0
           CALL BYTGET(buf(f+i+1), n, 3)
           CALL BYTGET(buf(f+i+2), n, 2)
           CALL BYTGET(buf(f+i+3), n, 1)
           CALL BYTGET(buf(f+i+4), n, 0)
           i = i + 4
           z = i + n
           IF (skip) THEN
             i = z
             GO TO 50
           END IF
           
*-----------------------------------------------------------------------
*            negative p       next byte is status
*            zero p           next byte is delta-time
*            positive p       next byte is data           
*-----------------------------------------------------------------------
           runk = -1           ! no running status
           runch = -1
           prev_ctl = -1       ! no previous controller event
           o = 0
           p = 0                ! expect a delta-time
           s = 0                 ! no accumulated ticks
           
*              check track length
           IF (i+n > L) THEN
             PRINT *, f_name(k), ': track ', j, ' longer than file'
             FAULT = 15
             RETURN
           END IF
           
*-----------------------------------------------------------------------
*             process the track
*-----------------------------------------------------------------------
           DO 40 WHILE (o < n)
             i = i + 1 
             o = o + 1
             IF (p) 10, 20, 30
             
*-----------------------------------------------------------------------
  10         CONTINUE           !        status byte
*-----------------------------------------------------------------------
             b = buf(f+i)
             IF (BTEST(b, 7)) THEN          ! status byte present
               newk = IBITS(b, 4, 4)            ! event kind
               newch = IBITS(b, 0, 4)             ! event channel
               IF (newk .GE. 8 .AND. newk .LE. 14) THEN  ! store running status
                 runk = newk
                 runch = newch
               END IF             

             ELSE                           ! status byte absent
               i = i - 1 
               o = o - 1                     ! back up a byte
               newk = runk                    ! retrieve from running status
               newch = runch
             END IF
             
*                delete previous controller
             IF (newk .NE. 11) prev_ctl = -1  
             
*                delete channel prefix
             IF (newk .NE. 15) prefix = -1
             
*-----------------------------------------------------------------------
*                NoteOff
*-----------------------------------------------------------------------
             IF (newk .EQ. 8) THEN
               g = g + 1
               p = 2              ! two bytes to follow
               e_s(g) = s
               e_k(g) = 0
               e_c(g) = newch

!!!!!!!!!!!!!!!!!! debug
!               IF (g .NE. gprev+1) PRINT *, 'OUT OF SEQUENCE: g= ', g
!               gprev = g
!             PRINT *, 'event ', g, ' is kind ', e_k(g)

               note = 0
               CALL BYTGET(buf(f+i+1), note, 0)
               IF (BTEST(note, 7)) THEN 
                 PRINT *, 'RMIDI: not a data byte!'
                 note = IBCLR(note, 7)
                 fault = 2
               END IF

               vel = 0
               CALL BYTGET(buf(f+i+2), vel, 0)
               IF (BTEST(vel, 7)) THEN
                 PRINT *, 'RMIDI: not a data byte!'
                 vel = IBCLR(vel, 7)
                 fault = 3
               END IF
               e_p1(g) = note
               e_p2(g) = ISHFT(vel, 7)    
               e_p3(g) = 0.       ! This has significance in key-finding  ?!?
               e_f(g) = k
               e_r(g) = j
               e_v(g) = 0
               e_g(g) = -1

*-----------------------------------------------------------------------
*               NoteOn (which may need to be converted to NoteOff)
*-----------------------------------------------------------------------
             ELSE IF (newk .EQ. 9) THEN
               g = g + 1
               p = 2
               e_s(g) = s
               e_c(g) = newch
               
               note = 0
               CALL BYTGET(buf(f+i+1), note, 0)
               IF (BTEST(note, 7)) THEN
                 PRINT *, 'RMIDI: not a data byte!'
                 note = IBCLR(note, 7)
                 fault = 4
               END IF
               
               vel = 0
               CALL BYTGET(buf(f+i+2), vel, 0)
               IF (BTEST(vel, 7)) THEN
                 PRINT *, 'RMIDI: not a data byte!'
                 vel = IBCLR(vel, 7)
                 fault = 5
               END IF
               e_p1(g) = note
               e_p2(g) = ISHFT(vel, 7)
               e_p3(g) = 0.              ! default value that will cause errors
               e_v(g) = 0                ! default values just in case
               e_g(g) = -1               !     "        "
               e_f(g) = k                ! correct track and file #s
               e_r(g) = j
               IF (vel .EQ. 0) THEN
                 e_k(g) = 0              ! actually a NoteOff
               ELSE
                 e_k(g) = 1 
                 kuse(1,j) = kuse(1,j) + 1             ! real NoteOn
               END IF

!!!!!!!!!!!!!!!!!! debug
!               IF (g .NE. gprev+1) PRINT *, 'OUT OF SEQUENCE: g= ', g
!               gprev = g
!             PRINT *, 'event ', g, ' is kind ', e_k(g)

               
*-----------------------------------------------------------------------
*               Aftertouch 
*-----------------------------------------------------------------------
             ELSE IF (newk .EQ. 10) THEN
               g = g + 1
               p = 2
               e_s(g) = s
               e_k(g) = 2 
               kuse(2,j) = kuse(2,j) + 1
               e_c(g) = newch
               
!!!!!!!!!!!!!!!!!! debug
!               IF (g .NE. gprev+1) PRINT *, 'OUT OF SEQUENCE: g= ', g
!               gprev = g
!             PRINT *, 'event ', g, ' is kind ', e_k(g)

               note = 0
               CALL BYTGET(buf(f+i+1), note, 0)
               IF (BTEST(note, 7)) THEN
                 PRINT *, 'RMIDI: not a data byte!'
                 note = IBCLR(note, 7)
                 fault = 6
               END IF

               vel = 0
               CALL BYTGET(buf(f+i+2), vel, 0)
               IF (BTEST(vel, 7)) THEN
                 PRINT *, 'RMIDI: not a data byte!'
                 vel = IBCLR(vel, 7)
                 fault = 7
               END IF              
               e_p1(g) = note
               e_p2(g) = vel           ! not hi-res
               e_f(g) = k
               e_r(g) = j
               e_v(g) = 0
               e_g(g) = -1
               
*-----------------------------------------------------------------------
*                   Controllers
*-----------------------------------------------------------------------
             ELSE IF (newk .EQ. 11) THEN
               c = buf(f+i+1)
               p = 2

*                  is this a fine-resolution controller?
               m = 0
               CALL BYTGET (c, m, 0)
               CALL IBSLE (ctlfin, n_fin, m, h)
               isfin = .FALSE.
               IF (h > 0) THEN               
                 IF (m .EQ. ctlfin(h)) isfin = .TRUE.
               END IF
               CALL IBSLE (ctlnum, n_ctl, m, h)
               isrec = .FALSE.
               IF (h > 0) THEN
                 isrec = m .EQ. ctlnum(h)          ! recognized at all?
               END IF
               
*                  combine fine bits with previous controller event
               IF ( isfin .AND. (newch .EQ. e_c(g))
     &                  .AND.  (c .EQ. prev_ctl + 32) ) THEN     
                 prev_ctl = -1
         
                 m = 0
                 CALL BYTGET(buf(f+i+2), m, 0) 
                 IF (BTEST(m, 7)) THEN
                   PRINT *, 'RMIDI: not a data byte!'
                   m = IBCLR(m, 7)
                   fault = 9
                 END IF
                 CALL MVBITS(m, 0, 7, e_p1(g), 0)      ! alter prior event 
                 e_p2(g) = 2
                 
*-----------------------------------------------------------------------
*                    new controller event
*-----------------------------------------------------------------------
               ELSE IF (isrec) THEN
                 g = g + 1
                 e_s(g) = s
                 e_c(g) = newch
                 e_r(g) = j
                 e_f(g) = k
                 e_v(g) = 0
                 e_g(g) = -1
                 prev_ctl = c

                 IF (c < 32) THEN                    ! MSB only
                   CALL BYTGET(buf(f+i+2), m, 0)
                   e_p1(g) = ISHFT(IBITS(m, 0, 7), 7)
                   e_p2(g) = 1
                 ELSE IF (c < 96) THEN               ! LSB only
                   e_p1(g) = IBITS(buf(f+i+2), 0, 7) 
                   e_p2(g) = 0
                 END IF
                 
                 IF (c .EQ. 0) THEN             ! bank select
                   kind = 3
                 ELSE IF (c .EQ. 1) THEN        ! wheel
                   kind = 4
                 ELSE IF (c .EQ. 2) THEN          ! breath
                   kind = 5
                 ELSE IF (c .EQ. 4) THEN          ! foot
                   kind = 6
                 ELSE IF (c .EQ. 5) THEN          ! portamento rate
                   kind = 7
                 ELSE IF (c .EQ. 6) THEN          ! data entry
                   kind = 8
                 ELSE IF (c .EQ. 7) THEN           ! volume
                   kind = 9
                 ELSE IF (c .EQ. 8) THEN              ! balance
                   kind = 10
                 ELSE IF (c .EQ. 10) THEN            ! pan
                   kind = 11
                 ELSE IF (c .EQ. 11) THEN           ! expression
                   kind = 12
                 ELSE IF (c .EQ. 12) THEN             ! effect 1
                   kind = 13
                 ELSE IF (c .EQ. 13) THEN              ! effect 2
                   kind = 14
                 ELSE IF (c .EQ. 16) THEN              ! general purpose 1
                   kind = 15
                 ELSE IF (c .EQ. 17) THEN             ! general purpose 2
                   kind = 16
                 ELSE IF (c .EQ. 18) THEN            ! general purpose 3
                   kind = 17
                 ELSE IF (c .EQ. 19) THEN             ! general purpose 4
                   kind = 18
                 ELSE IF (c .EQ. 32) THEN            ! fine control for 0-31
                   kind = 3
                 ELSE IF (c .EQ. 33) THEN
                   kind = 4
                 ELSE IF (c .EQ. 34) THEN                    
                   kind = 5
                 ELSE IF (c .EQ. 36) THEN
                   kind = 6
                 ELSE IF (c .EQ. 37) THEN
                   kind = 7
                 ELSE IF (c .EQ. 38) THEN
                   kind = 8
                 ELSE IF (c .EQ. 39) THEN
                   kind = 9
                 ELSE IF (c .EQ. 40) THEN
                   kind = 10
                 ELSE IF (c .EQ. 42) THEN
                   kind = 11
                 ELSE IF (c .EQ. 43) THEN
                   kind = 12
                 ELSE IF (c .EQ. 44) THEN
                   kind = 13
                 ELSE IF (c .EQ. 45) THEN
                   kind = 14
                 ELSE IF (c .EQ. 48) THEN
                   kind = 15
                 ELSE IF (c .EQ. 49) THEN
                   kind = 16
                 ELSE IF (c .EQ. 50) THEN
                   kind = 17
                 ELSE IF (c .EQ. 51) THEN
                   kind = 18
                 ELSE IF (c .GE. 64 .AND. c .LE. 83) THEN    ! misc.
                   kind = c - 45
                 ELSE IF (c .EQ. 84) THEN     ! portamento control
                   kind = 39
                 ELSE IF (c .EQ. 88) THEN     ! hi-res velocity
                   kind = 40
                   usehrv = .TRUE.
                 ELSE IF (c .EQ. 91) THEN             ! reverb
                   kind = 41
                 ELSE IF (c .EQ. 92) THEN             ! tremolo
                   kind = 42
                 ELSE IF (c .EQ. 93) THEN             ! chorus
                   kind = 43
                 ELSE IF (c .EQ. 94) THEN             ! celeste/detune
                   kind = 44
                 ELSE IF (c .EQ. 95) THEN              ! phaser
                   kind = 45

*      increment/decrement buttons
                 ELSE IF (c .EQ. 96) THEN             ! data button increment
                   kind = 46
                   e_p1(g) = 1
                 ELSE IF (c .EQ. 97) THEN             ! data button decrement
                   kind = 46
                   e_p1(g) = -1
                 ELSE IF (c .EQ. 98) THEN                ! NRPN fine only
                   kind = 47
                   e_p1(g) = IBITS(buf(f+i+2), 0, 7)
                   e_p2(g) = 0
                 ELSE IF (c .EQ. 99) THEN                    ! NRPN coarse
                   kind = 47
                   CALL BYTGET(buf(f+i+2), m, 0)
                   e_p1(g) = ISHFT(IBITS(m, 0, 7), 7)
                   e_p2(g) = 1
                 ELSE IF (c .EQ. 100) THEN       ! registered parameter fine
                   kind = 48
                   e_p1(g) = IBITS(buf(f+i+2), 0, 7)
                   e_p2(g) = 0
                 ELSE IF (c .EQ. 101) THEN      ! registered parameter coarse
                   kind = 48
                   CALL BYTGET(buf(f+i+2), m, 0)
                   e_p1(g) = ISHFT(IBITS(m, 0, 7), 7)
                   e_p2(g) = 1
                 ELSE IF (c .EQ. 120) THEN         ! all sound off
                   kind = 49
                   e_p1(g) = 0
                 ELSE IF (c .EQ. 121) THEN          ! all controllers off
                   kind = 50
                   e_p1(g) = 0
                 ELSE IF (c .EQ. 122) THEN          ! local keyboard off/on
                   kind = 51
                   e_p1(g) = IBITS(buf(f+i+2), 0, 7) 
                 ELSE IF (c .EQ. 123) THEN           ! all notes off
                   kind = 52
                   e_p1(g) = 0
                 ELSE IF (c .EQ. 124) THEN           ! Omni off
                   kind = 53
                   e_p1(g) = 0
                 ELSE IF (c .EQ. 125) THEN            ! Omni on
                   kind = 53 
                   e_p1(g) = 127
                 ELSE IF (c .EQ. 126) THEN            ! Mono mode
                   kind = 54
                   e_p1(g) = 0
                   e_p2(g) = IBITS(buf(f+i+2), 0, 7) 
                   IF (e_p2(g) > 16) THEN
                     PRINT *, 'RMIDI: bad mono # channels'
                     fault = 126
                   END IF
                 ELSE IF (c .EQ. 127) THEN             ! Poly mode
                   kind = 54
                   e_p1(g) = 127
                 ELSE
                   kind = 99                        ! avoid compiler warning
                 END IF
                 e_k(g) = kind       ! store kind found above
                 IF (kind .LE. n_kind) kuse(kind,j) = kuse(kind,j) + 1

               ELSE 
!                 PRINT *, 'unrecognized controller: ', c
!                 fault = 22
                 CONTINUE  ! without printing error
               END IF
             
*-----------------------------------------------------------------------
*               patch change                 
*-----------------------------------------------------------------------
             ELSE IF (newk .EQ. 12) THEN
               g = g + 1
               p = 1              ! one byte to follow
               e_k(g) = 55 
               kuse(55,j) = kuse(55,j) + 1
               e_c(g) = newch
               e_s(g) = s
               
               m = 0
               CALL BYTGET(buf(f+i+1), m, 0)
               IF (BTEST(m, 7)) THEN 
                 PRINT *, 'RMIDI: not a data byte'
                 fault = 30
                 m = IBCLR(m, 7)
               END IF
               e_p1(g) = m
               e_f(g) = k
               e_r(g) = j
               e_v(g) = 0
               e_g(g) = -1

*-----------------------------------------------------------------------
*                channel pressure
*-----------------------------------------------------------------------
             ELSE IF (newk .EQ. 13) THEN 
               g = g + 1
               p = 1
               e_k(g) = 56 
               kuse(56,j) = kuse(56,j) + 1
               e_c(g) = newch
               e_s(g) = s

               m = 0
               CALL BYTGET(buf(f+i+1), m, 0)
               IF (BTEST(m, 7)) THEN
                 PRINT *, 'RMIDI: not a data byte!'
                 fault = 31
                 m = IBCLR(m, 7)
               END IF
               e_p1(g) = m
               e_f(g) = k
               e_v(g) = 0
               e_g(g) = -1
               e_r(g) = j
               
*-----------------------------------------------------------------------
*                 pitch bend
*-----------------------------------------------------------------------
             ELSE IF (newk .EQ. 14) THEN
               g = g + 1
               p = 2
               e_k(g) = 57 
               kuse(57,j) = kuse(57,j) + 1
               e_c(g) = newch
               e_s(g) = s

               e_p1(g) = 0
               m = 0
               CALL BYTGET(buf(f+i+1), m, 0)
               IF (BTEST(m, 7)) THEN 
                 PRINT *, 'RMIDI: not a data byte!'
                 fault = 11
                 m = IBCLR(m, 7)
               END IF
               CALL MVBITS (m, 0, 7, e_p1(g), 0)

               m = 0
               CALL BYTGET(buf(f+i+2), m, 0)
               IF (BTEST(m, 7)) THEN
                 PRINT *, 'RMIDI: not a data byte!'
                 fault = 12
                 m = IBCLR(m, 7)
               END IF
               CALL MVBITS (m, 0, 7, e_p1(g), 7)

               e_f(g) = k
               e_r(g) = j
               e_v(g) = 0
               e_g(g) = -1
               
*-----------------------------------------------------------------------
*                 meta and other events
*-----------------------------------------------------------------------
             ELSE IF (newk .EQ. 15) THEN

*     system exclusive and continued system exclusive
               IF (newch .EQ. 0 .OR. newch .EQ. 7) THEN
                 CALL declen(buf(f+1), varb, i, o, L, n, p)
                 g = g + 1
                 IF (newch .EQ. 0) THEN
                   kind = 58
                 ELSE IF (newch .EQ. 7) THEN
                   kind = 59
                 ELSE 
                   kind = 99
                   PRINT *, 'RMIDI: unrecognized status'
                   fault = 58
                 END IF
                 e_k(g) = kind 
                 IF (kind .LE. n_kind) THEN
                   kuse(kind,j) = kuse(kind,j) + 1
                 END IF
                 IF (prefix .EQ. -1) THEN
                   e_c(g) = MOD(j+14, 16) 
                 ELSE 
                   e_c(g) = prefix 
                 END IF
                 e_s(g) = s
                 e_p1(g) = f + i + 1         ! pointer into buf
                 e_p2(g) = p
                 e_f(g) = k
                 e_r(g) = j
                 e_v(g) = 0
                 e_g(g) = -1
                                 
               ELSE IF (newch .EQ. 15) THEN           ! meta
                 i = i + 1 
                 o = o + 1

                 meta = 0
                 CALL BYTGET(buf(f+i), meta, 0)
                 IF (BTEST(meta, 7)) THEN
                   PRINT *, 'RMIDI:  meta out of bounds at offset ', f+i
                   PRINT *, '(value of ', meta, ' is not allowed)'
                   fault = 32
                 END IF

*                    decode length of the meta event
                 CALL declen(buf(f+1), varb, i, o, L, n, p) 
                 
                 IF (meta .EQ. 0) THEN            ! sequence #
                   g = g + 1
                   e_k(g) = 60 
                   kuse(60,j) = kuse(60,j) + 1
                   IF (prefix .EQ. -1) THEN
                     e_c(g) = MOD(j+14, 16)    ! associate channels with tracks
                   ELSE 
                     e_c(g) = prefix         ! needed in case of option 'C'
                   END IF
                   e_s(g) = s
                   e_f(g) = k
                   e_r(g) = j
                   e_v(g) = 0
                   e_g(g) = -1
                   IF (p .EQ. 0) THEN
                     e_p1(g) = j - 1
                   ELSE IF (p .EQ. 2) THEN
                     m = 0
                     CALL BYTGET(buf(f+i+1), m, 1)
                     CALL BYTGET(buf(f+i+2), m, 0)
                     e_p1(g) = m
                   ELSE
                     PRINT *, 'bad length value for sequence #, p=', p
                     fault = 15
                   END IF
                  
*-----------------------------------------------------------------------
*                    text-like events
*-----------------------------------------------------------------------
                 ELSE IF (meta > 0 .AND. meta < 10) THEN
                   g = g + 1
                   e_s(g) = s           
                   IF (prefix .EQ. -1) THEN
                     e_c(g) = MOD(j+14, 16)   ! associate channels with tracks
                   ELSE 
                     e_c(g) = prefix         ! needed in case of option 'C'
                   END IF
                   e_p1(g) = f + i + 1         ! pointer to begining of text
                   e_p2(g) = p                 ! length of text
                   e_f(g) = k
                   e_r(g) = j
                   e_v(g) = 0
                   e_g(g) = -1
                   
                   IF (meta .EQ. 1) THEN
                     kind = 61
                   ELSE IF (meta .EQ. 2) THEN
                     kind = 62
                   ELSE IF (meta .EQ. 3) THEN
                     kind = 63
                   ELSE IF (meta .EQ. 4) THEN
                     kind = 64
                   ELSE IF (meta .EQ. 5) THEN
                     kind = 65
                   ELSE IF (meta .EQ. 6) THEN
                     kind = 66
                   ELSE IF (meta .EQ. 7) THEN
                     kind = 67
                   ELSE IF (meta .EQ. 8) THEN
                     kind = 68
                   ELSE IF (meta .EQ. 9) THEN
                     kind = 69
                   ELSE
                     fault = -9
                     PRINT *, 'RMIDI: mixed up meta text #'
                     RETURN
                   END IF
                   e_k(g) = kind
                   kuse(kind,j) = kuse(kind,j) + 1

*-----------------------------------------------------------------------
*                       channel prefix - don't make an event 
*-----------------------------------------------------------------------
                 ELSE IF (meta .EQ. 32) THEN
                   prefix = 0
                   CALL BYTGET(buf(f+i+1), prefix, 0)
                 
*-----------------------------------------------------------------------
*                      end of track                   
*-----------------------------------------------------------------------
                 ELSE IF (meta .EQ. 47) THEN
                   IF (o .NE. n) THEN
                     PRINT *, f_name(k), ': end of track at ', o
                     PRINT *, 'file offset ', i, ' track length: ', n
                     fault = 13
                   END IF
                   i = z         
                   GO TO 50       ! next track
                 
*-----------------------------------------------------------------------
*                        schedule events
*-----------------------------------------------------------------------
*                                tempo 
                 ELSE IF (meta .EQ. 81) THEN     
                   g = g + 1
                   e_s(g) = s
                   e_k(g) = 70 
                   kuse(70,1) = kuse(70,1) + 1
                   e_c(g) = 15         ! to correspond to track 1

                   m = 0
                   CALL BYTGET(buf(f+i+1), m, 2)
                   CALL BYTGET(buf(f+i+2), m, 1)
                   CALL BYTGET(buf(f+i+3), m, 0)
                     
                   e_p1(g) = m                ! microseconds per quarter note
                   e_p3(g) = 1 000 000. / FLOAT(m)    ! Hertz
                   e_f(g) = k
                   e_r(g) = 1         ! move to track 1
                   e_v(g) = 0
                   e_g(g) = -1
                     
*                         SMPTE offset 
                 ELSE IF (meta .EQ. 84) THEN 
                   IF (.NOT. donset) THEN      ! ignore multiple SMPTE events
                     donset = .TRUE.
                     g = g + 1
                     e_s(g) = 0               ! move to the beginning 
                     e_k(g) = 71 
                     kuse(71,1) = kuse(71,1) + 1
                     e_c(g) = 15
                     
                     offset = 0.
                     m = IBITS(buf(f+i+1), 5, 2)
                     IF (m .EQ. 0) THEN
                       fps = 24.
                     ELSE IF (m .EQ. 1) THEN
                       fps = 25.
                     ELSE IF (m .EQ. 2) THEN
                       fps = 29.97
                     ELSE IF (m .EQ. 3) THEN
                       fps = 30.
                     ELSE
                       fault = 16
                       PRINT *, 'illegal frame per second value'
                     END IF
                     m = IBITS(buf(f+i+1), 0, 5)     ! hours
                     IF (m > 24) THEN 
                       PRINT *, 'RMIDI: hours out of bounds'
                       fault = 16
                     END IF
                     offset = m * 3600
                     m = IBITS(buf(f+i+2), 0, 7)    ! minutes
                     IF (m > 59) THEN
                       PRINT *, 'RMIDI: minutes out of bounds'
                       fault = 17
                     END IF
                     offset = offset + m * 60
                     m = IBITS(buf(f+i+3), 0, 7)   ! seconds
                     IF (m > 59) THEN
                       PRINT *, 'RMIDI:  seconds out of bounds'
                       fault = 18
                     END IF
                     offset = offset + m
                     m = IBITS(buf(f+i+4), 0, 7)   ! frames
                     IF (m .GE. NINT(fps)) THEN
                       PRINT *, 'RMIDI:  frames out of bounds'
                       fault = 19
                     END IF
                     offset = offset + m / fps
                     m = IBITS(buf(f+i+5), 0, 7)  ! sub-frames
                     IF (m > 99) THEN
                       PRINT *, 'RMIDI: sub-frames out of bounds'
                       fault = 20
                     END IF
                     offset = offset + m / (100. * fps)
                     e_p3(g) = offset
                     e_f(g) = k
                     e_r(g) = 1            ! move to track 1
                     e_v(g) = 0
                     e_g(g) = -1
                   END IF         ! SMPTE offset is unique in file ?

*                        time signature                       
                 ELSE IF (meta .EQ. 88) THEN
                   g = g + 1
                   e_s(g) = s
                   e_k(g) = 72 
                   kuse(72,1) = kuse(72,1) + 1
                   e_c(g) = 15
                     
*    quote from the SonicSpot:
* "The numerator is specified as a literal value, but the denominator is
* specified as (get ready) the value to which the power of 2 must be raised
* to equal the number of subdivisions per whole note."
                   e_p1(g) = IBITS(buf(f+i+1), 0, 7)
                   e_p2(g) = IBITS(buf(f+i+2), 0, 7) ! don't interpret
                   e_r(g) = 1         ! move to track 1
                   e_f(g) = k
                   e_v(g) = 0
                   e_g(g) = -1
                   
*                      key signature                     
                 ELSE IF (meta .EQ. 89) THEN
                   g = g + 1
                   e_k(g) = 73 
                   kuse(73,1) = kuse(73,1) + 1
                   e_c(g) = 15
                   e_s(g) = s
                   c = buf(f+i+1)
                   IF (c > -8 .AND. c < 8) THEN
                     e_p1(g) = c                  ! sharps, signed
                   ELSE
                     PRINT *, 'RMIDI: bad sharps value'
                     fault = 33
                     e_p1(g) = 0
                   END IF
                    
                   c = buf(f+i+2)
                   IF (c .EQ. 0 .OR. c .EQ. 1) THEN
                     e_p2(g) = c
                   ELSE
                     PRINT *, 'RMIDI: bad mode value'
                     fault = 21
                     e_p2(g) = 0
                   END IF
                   e_r(g) = 1         ! move to track 1
                   e_f(g) = k                               
                   e_v(g) = 0
                   e_g(g) = -1
                 
*-----------------------------------------------------------------------
*         XMF patch type (addendum to MIDI standard)
*-----------------------------------------------------------------------
                 ELSE IF (meta .EQ. 96) THEN
                   IF (.NOT. donxmf) THEN
                     donxmf = .TRUE.
                     g = g + 1
                     e_k(g) = 74 
                     kuse(74,j) = kuse(74,j) + 1
                     IF (prefix .EQ. -1) THEN
                       e_c(g) = MOD(j+14, 16)   
                     ELSE 
                       e_c(g) = prefix  
                     END IF
                     e_s(g) = s
                     c = buf(f+i+1)
                     IF (c > 0 .AND. c < 4) THEN
                       e_p1(g) = c                 ! {1,2,3}
                     ELSE
                       PRINT *, 'RMIDI: bad XMF type'
                       fault = 96
                       e_p1(g) = 1
                     END IF
                     e_r(g) = j             ! respect original track
                     e_f(g) = k
                     e_v(g) = 0
                     e_g(g) = -1
                   END IF
                 
*                   proprietary a.k.a. sequencer specific
                 ELSE IF (meta .EQ. 127) THEN
                   g = g + 1
                   e_s(g) = s           
                   e_k(g) = 75 
                   kuse(75,j) = kuse(75,j) + 1
                   IF (prefix .EQ. -1) THEN
                     e_c(g) = MOD(j+14,16)     ! associate channels with tracks
                   ELSE 
                     e_c(g) = prefix         ! needed in case of option 'C'
                   END IF
                   e_p1(g) = f + i + 1         ! pointer to begining of text
                   e_p2(g) = p                 ! length of text
                   e_f(g) = k
                   e_r(g) = j
                   e_v(g) = 0
                   e_g(g) = -1
                 END IF

*                   unrecognized status byte 0xF?
               ELSE
                 PRINT *,f_name(k),' at ',i,' realtime/unrecognized', b
                 fault = 14
               END IF   ! meta or sysex?
                
*                bad status value
             ELSE
               prev_ctl = -1
               PRINT *, 'invalid running status value'
               runk = 9 
               runch = 0                         ! look for notes
             END IF
             
             GO TO 40                !  back to the top of the WHILE loop
             
*-----------------------------------------------------------------------
  20         CONTINUE                !  read in a delta-time
*-----------------------------------------------------------------------
             IF (o > n-3) THEN
               PRINT *, 'premature end of track!'
               FAULT = 17
               RETURN
             END IF
             
             s = s + RVARB(p, buf(f+i))             ! read, accumulate ticks
             i = i + p -1 
             o = o + p -1      ! advance pointer
             p = -1
             GO TO 40                 ! look for a status byte
             
*-----------------------------------------------------------------------
  30         CONTINUE                ! skip through data bytes
*-----------------------------------------------------------------------
             p = p - 1  
  40       CONTINUE  ! buffer position loop
                    
  50     CONTINUE   ! per-track loop

*-----------------------------------------------------------------------
*                  get real times and synchronize
*-----------------------------------------------------------------------
         h = g - r + 1

*                   sort by ticks
         s = 0
         DO i = r, g
           IF (e_s(i) > s) s = e_s(i)              ! find most ticks
         END DO 
         IF (s > 0) THEN 
           m = BITSZ()
           DO WHILE (.NOT. BTEST(s, m-1))   ! significant bits in s
             m = m - 1
           END DO
         ELSE
           m = 1
         END IF

         DO i = 1, h
           ind(i) = i                              ! initialize array
         END DO 
         CALL RSORTI (e_s(r), ind, h, m, JSW)          ! stable sort
         CALL IORDER (e_k(r), ind, h)                   ! apply to kind
         CALL IORDER (e_c(r), ind, h)                    ! apply to channel
         CALL IORDER (e_p1(r), ind, h)                    ! apply to data
         CALL IORDER (e_p2(r), ind, h)
         CALL RORDER (e_p3(r), ind, h)
         CALL IORDER (e_v(r), ind, h)
         CALL IORDER (e_g(r), ind, h)
!         CALL IORDER(e_f(r), ind, h)                     ! apply to file #
         CALL IORDER (e_r(r), ind, h)                       ! apply to track #
                             

*              all sounds hushed at beginning 
         DO m = 0, 15
           DO h = 0, 127
             psi(h,m) = 0
           END DO
         END DO
  
*               reset controllers with a saved state
         DO chan = 0, 15
           CALL reset_ctl(spar, chan)
           nrpn(chan) = 16383
           rpn(chan) = 16383         ! set registered parameters to nothing
           hrv(chan) = 0             ! null hi-resolution velocity
           prtm(chan) = -1           ! no portamento note
         END DO
         reg = .TRUE.             ! avoid compiler warning
         
*-----------------------------------------------------------------------
*   for all events in file, convert to real time.  Credit to Armory Wong 
*   for his article that explains this conversion:
*     the MidiStar program, published at www.codeproject.com
*-----------------------------------------------------------------------
         gg = 0                   ! no events appended to this file yet
         s = 0 
         t = 0.
         u = 0.
         rdiv = 1. / FLOAT(div)
         
!!!!!!!!!!!!!! debugging
           IF (rdiv .NE. rdiv) THEN
             PRINT *, 'rmidi: NaN r divisor!'
             PRINT *, 'div was ', DIV, ' float(div): ', FLOAT(div)
             STOP
           END IF
         
         bps = 2.0                    ! 120 bpm default
         DO i = r, g
           sprev = s
           s = e_s(i)
           dt = spt * (s - sprev)      ! time [s] between events
           t = t + dt
           e_t(i) = t
           IF (smpte) THEN             ! beat this event
             u = u + bps * dt
           ELSE
             u = FLOAT(s) * rdiv
           END IF
           
!!!!!!!!!!!!!! debugging
           IF (u .NE. u) THEN
             PRINT *, 'rmidi: NaN metrical time'
             PRINT *, 's was ', S, ' smpte: ', smpte, ' bps ', BPS,
     &         ' dt: ', DT, ' rdiv: ', RDIV
             STOP
           END IF
           
           e_u(i) = u
           
*-----------------------------------------------------------------------
*               verify the Note On/Off state, find duration
*-----------------------------------------------------------------------
           kind = e_k(i)
           chan = e_c(i)
           IF (kind .EQ. 0) THEN        ! NoteOff
             note = e_p1(i)
             h = psi(note,chan)                ! event that turned this note on
             IF (h > 0) THEN        ! find the duration
               psi(note,chan) = -h            ! turn off note
               e_p3(h) = e_t(i) - e_t(h)
               e_v(h) = IOR(e_p2(i), hrv(chan)) ! off velocity, with hi-res
               hrv(chan) = 0
             ELSE IF (OPT_N) THEN
               hrv(chan) = 0  ! can't uniquely identify a corresponding Note-On
             ELSE IF (h < 0) THEN
               h = -h
               e_p3(h) = e_t(i) - e_t(h)      ! extend duration
             ELSE
               e_k(i) = 99                  ! bogus NoteOff - mark as non-event
               PRINT *, 'RMIDI: bogus Note-off! pitch: ', note, 
     &           ' at ticks: ', s, ' chanell: ', chan
             END IF
           
           ELSE IF (kind .EQ. 1) THEN      ! NoteOn
             note = e_p1(i)
             h = psi(note,chan)
             IF (h .LE. 0 .OR. OPT_N) THEN               ! turn on
               psi(note,chan) = i
               e_p2(i) = IOR(e_p2(i), hrv(chan))  ! store hi-res velocity
               hrv(chan) = 0
               e_g(i) = prtm(chan)                ! store portamento prefix
               prtm(chan) = -1
             ELSE                     ! keep
               e_p3(h) = e_t(i) - e_t(h)          ! shorten duration
               IF (e_p3(h) > 0.) THEN
                 e_v(h) = 0
                 psi(note,chan) = i                ! begin a new note
                 e_p2(i) = IOR(e_p2(i), hrv(chan))
                 hrv(chan) = 0
                 e_g(i) = prtm(chan)
                 prtm(chan) = -1

*                    turn off old note
                 gg = gg + 1                      ! make a Note-Off
                 e_t(g+gg) = e_t(i)                  ! at same time as new note
                 e_u(g+gg) = e_u(i)
                 e_k(g+gg) = 0 
                 e_c(g+gg) = chan                   ! on same channel as old 
                 e_p1(g+gg) = note                
                 e_p2(g+gg) = 0                    ! usual NoteOff velocity 
                 e_p3(g+gg) = 0.
                 e_f(g+gg) = k
                 e_r(g+gg) = e_r(h)           ! on same track as old
                 e_v(g+gg) = 0
                 e_g(g+gg) = -1

               ELSE                            ! prevent zero-duration notes
                 e_k(i) = 99
               END IF      ! zero duration ?
             END IF     ! note sounding ?
               
*-----------------------------------------------------------------------
*                  check that aftertouch is valid
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 2) THEN             
             note = e_p1(i)
             h = psi(note,chan)
             IF (h .EQ. 0) THEN
               e_k(i) = 99         ! a non-event
               PRINT*, 'RMIDI: bogus aftertouch!'
             END IF

*-----------------------------------------------------------------------
*                  change fine-adjustable controllers             
*-----------------------------------------------------------------------
           ELSE IF (kind .GE. 3 .AND. kind .LE. 18) THEN
             IF (e_p2(i) .EQ. 0) THEN         ! append coarse bits
               CALL MVBITS (spar(kind-2,chan), 7, 7, e_p1(i), 7)
             ELSE IF (e_p2(i) .EQ. 1 .OR. e_p2(i) .EQ. 2) THEN 
               CALL MVBITS (e_p1(i), 7, 7, spar(kind-2,chan), 7)
             ELSE
               PRINT *, 'bad value for parameter 2', e_p2(i), ' i:' , I
               fault = -22
             END IF
             
*-----------------------------------------------------------------------
*    set Portamento control and Hi-Res velocity prefixes
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 39) THEN
             prtm(chan) = e_p1(i)
             e_k(i) = 99
           ELSE IF (kind .EQ. 40) THEN
             hrv(chan) = e_p1(i)
             e_k(i) = 99
             
*-----------------------------------------------------------------------
*                   non-registered parameter
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 47) THEN
             e_k(i) = 99     ! so that slider/button events can have #47
             reg = .FALSE.
             rpn(chan) = 16383
             IF (e_p2(i) .EQ. 0) THEN
               CALL MVBITS (e_p1(i), 0, 7, nrpn(chan), 0)
             ELSE IF (e_p2(i) .EQ. 1) THEN
               CALL MVBITS (e_p1(i), 7, 7, nrpn(chan), 7)
             ELSE
               PRINT *, 'bad nrpn e_p2 value!'
               fault = -8
             END IF
             
*-----------------------------------------------------------------------
*               change RPN     
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 48) THEN
             e_k(i) = 99
             reg = .TRUE.
             nrpn(chan) = 16383
             IF (e_p2(i) .EQ. 0) THEN         ! LSB
               CALL MVBITS (e_p1(i), 0, 7, rpn(chan), 0)
             ELSE IF (e_p2(i) .EQ. 1) THEN
               CALL MVBITS (e_p1(i), 7, 7, rpn(chan), 7)
             ELSE
               PRINT *, 'bad rpn e_p2 value!'
               fault = -48
             END IF
             
*-----------------------------------------------------------------------
*                all sound/notes off
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 49 .OR. kind .EQ. 52) THEN
             DO m = 0, 127
               h = psi(m,chan)
               IF (h > 0) THEN
                 e_p3(h) = e_t(i) - e_t(h)
                 psi(m,chan) = 0
               END IF
             END DO
               
*             all controllers off
           ELSE IF (kind .EQ. 50) THEN
             CALL reset_ctl(spar, chan) 
             nrpn(chan) = 16383
             rpn(chan) = 16383
                        
*-----------------------------------------------------------------------
*               change tempo  (taking care not to disturb SMPTE timing)
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 70) THEN
             bps = 1 000 000. / FLOAT(e_p1(i))        ! beats per second
             IF (.NOT. smpte) spt = e_p1(i) / (1 000 000. * div)
           END IF
             
*-----------------------------------------------------------------------
*              change parameters
*-----------------------------------------------------------------------
           IF (kind .EQ. 8) THEN            ! data entry slider           
             IF (reg) THEN
               IF (rpn(chan) .EQ. 0) THEN       ! pitch bend range: cents
                 e_k(i) = 76                      ! Convert event
                 IF (e_p2(i) .EQ. 0) THEN    
                   m = spar(17,chan) / 100        ! old semitones
                 ELSE IF (e_p2(i) .EQ. 1 .OR. e_p2(i) .EQ. 2) THEN  
                   m = IBITS(e_p1(i), 7, 7)       ! new semitones
                 ELSE
                   fault = -3
                   print *, 'RMIDI:  bad value for e_p2'
                   RETURN
                 END IF
                 n = IBITS(e_p1(i), 0, 7)     ! LSB
                 IF (n > 99) THEN
                   PRINT *, 'RMIDI: cents to big!'
                   fault = 100
                 END IF
                 m = m * 100 + n
                 e_p1(i) = m
                 spar(17,chan) = m
             
               ELSE IF (rpn(chan) .EQ. 1) THEN     ! fine tuning: 0-16383
                 e_k(i) = 77
                 IF (e_p2(i) .EQ. 0) THEN   
                   CALL MVBITS (spar(18,chan), 7, 7, e_p1(i), 7)
                 ELSE IF (e_p2(i) .EQ. 1 .OR. e_p2(i) .EQ. 2) THEN  
                   spar(18,chan) = e_p1(i)
                 ELSE 
                   PRINT *, 'bad value for e_p2: should never happen'
                   fault = -4
                   RETURN
                 END IF
               
               ELSE IF (rpn(chan) .EQ. 2) THEN      ! coarse tuning: 0-127
                 e_k(i) = 78
                 IF (e_p2(i) .EQ. 0) THEN
                   e_k(i) = 99               ! bogus -- don't use fine bits 
                 ELSE IF (e_p2(i) .EQ. 1 .OR. e_p2(i) .EQ. 2) THEN
                   m = IBITS(e_p1(i), 7, 7)
                   e_p1(i) = m
                   spar(19,chan) = m
                 ELSE
                   FAULT = -5
                   RETURN
                 END IF
               
               ELSE IF (rpn(chan) .EQ. 3) THEN      ! tuning program: 0-127
                 e_k(i) = 79
                 IF (e_p2(i) .EQ. 0) THEN
                   e_k(i) = 99 
                 ELSE IF (e_p2(i) .EQ. 1 .OR. e_p2(i) .EQ. 2) THEN
                   m = IBITS(e_p1(i), 7, 7)
                   e_p1(i) = m
                   spar(20,chan) = m
                 ELSE
                   fault = -6
                   RETURN
                 END IF
                 
               ELSE IF (rpn(chan) .EQ. 4) THEN     ! tuning bank:  0-127
                 e_k(i) = 80
                 IF (e_p2(i) .EQ. 0) THEN
                   e_k(i) = 99 
                 ELSE IF (e_p2(i) .EQ. 1 .OR. e_p2(i) .EQ. 2) THEN
                   m = IBITS(e_p1(i), 7, 7)
                   e_p1(i) = m
                   spar(21,chan) = m
                 ELSE
                   fault = -7
                   RETURN
                 END IF
              
               ELSE IF (rpn(chan) .EQ. 5) THEN      ! mod depth range:  0-16383
                 e_k(i) = 81
                 IF (e_p2(i) .EQ. 0) THEN
                   CALL MVBITS (spar(22,chan), 7, 7, e_p1(i), 7)
                 ELSE IF (e_p2(i) .EQ. 1 .OR. e_p2(i) .EQ. 2) THEN
                   spar(22,chan) = e_p1(i)
                 ELSE
                   fault = -19
                   RETURN
                 END IF
               
*   3-D controllers
               ELSE IF (rpn(chan) .GE. 7808 
     &                  .AND. rpn(chan) .LE. 7816) THEN
                 e_k(i) = rpn(chan) - 7726
                 m = rpn(chan) - 7789
                 IF (e_p2(i) .EQ. 0) THEN   
                   CALL MVBITS (spar(m,chan), 7, 7, e_p1(i), 7)
                 ELSE IF (e_p2(i) .EQ. 1 .OR. e_p2(i) .EQ. 2) THEN  
                   spar(m,chan) = e_p1(i)
                 ELSE
                   fault = -61
                   PRINT *, 'error setting 3d value!'
                 END IF
             
               ELSE               ! undefined RPN's not supported.
                 e_k(i) = 99
               END IF  ! rpn # ?
             
             ELSE        ! NRPN's pass thru
               e_k(i) = 47           ! all same kind
               e_p2(i) = e_p1(i)     ! so that the par value
               e_p1(i) = nrpn(chan)  ! follows the par ID
             END IF   ! registered ?
             
*-----------------------------------------------------------------------
*                data button
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 46) THEN         ! data button
             IF (reg) THEN
               IF (rpn(chan) .EQ. 0) THEN           ! bend range
                 e_k(i) = 76
                 m = spar(17,chan) + e_p1(i)
                 m = MIN(MAX(0, m), 12799)           ! impose limits
                 e_p1(i) = m
                 spar(17,chan) = m
               ELSE IF (rpn(chan) .EQ. 1) THEN       ! fine tuning
                 e_k(i) = 77
                 m = spar(18,chan) + e_p1(i)
                 m = MIN(MAX(0, m), 16383)
                 e_p1(i) = m
                 spar(18,chan) = m
               ELSE IF (rpn(chan) .EQ. 2) THEN       ! coarse tuning
                 e_k(i) = 78
                 m = spar(19,chan) + e_p1(i)
                 m = MIN(MAX(0, m), 127)
                 e_p1(i) = m
                 spar(19,chan) = m
               ELSE IF (rpn(chan) .EQ. 3) THEN      ! tuning program
                 e_k(i) = 79
                 m = spar(20,chan) + e_p1(i)
                 m = MIN(MAX(0, m), 127)
                 e_p1(i) = m
                 spar(20,chan) = m
               ELSE IF (rpn(chan) .EQ. 4) THEN      ! tuning bank
                 e_k(i) = 80
                 m = spar(21,chan) + e_p1(i)
                 m = MIN(MAX(0, m), 127)
                 e_p1(i) = m
                 spar(21,chan) = m
               ELSE IF (rpn(chan) .EQ. 5) THEN
                 e_k(i) = 81
                 m = spar(22,chan) + e_p1(i)
                 m = MIN(MAX(0, m), 16383)
                 e_p1(i) = m
                 spar(22,chan) = m
               ELSE IF (rpn(chan) .GE. 7808
     &                  .AND. rpn(chan) .LE. 7816) THEN
                 e_k(i) = rpn(chan) - 7726
                 n = rpn(chan) - 7789
                 m = spar(n,chan) + e_p1(i)
                 m = MIN(MAX(0, m), 16383)
                 e_p1(i) = m
                 spar(n,chan) = m
               ELSE                                 ! no unrecognized RPN's
                 e_k(i) = 99
               END IF      ! which RPN ?
             ELSE
               e_k(i) = 99             ! data button not supported for NRPN
             END IF  ! registered or non-registered parameter ?
           END IF ! kind of event ?
         END DO  ! next event i
         
*-----------------------------------------------------------------------
*             begin together
*-----------------------------------------------------------------------
         IF (opt_b) THEN
           offset = 18748800.                       ! a month of Sundays
           DO i = r, g+gg                         ! find earliest note onset
             IF (e_k(i) .EQ. 1) offset = MIN(offset, e_t(i))
           END DO
           DO i = r, g+gg                    ! subtract
             e_t(i) = DIM(e_t(i), offset)
           END DO
         END IF       ! option "B"
                    
*              remember time of last event
         tend(k) = e_t(g)                 
         
*-----------------------------------------------------------------------
*              turn off any notes still sounding             
*-----------------------------------------------------------------------
         IF (.NOT. opt_N) THEN
           DO j = 0, 15
             DO i = 0, 127
               IF (psi(i,j) > 0) THEN           ! insert NoteOff event
                 PRINT*, 'warning: note ',i,j,' left on at end of track'
                 h = psi(i,j)
                 psi(i,j) = 0                    ! make sure it's marked off
                 e_p3(h) = tend(k) - e_t(h)        ! set duration
                 e_v(h) = 0
                 e_g(h) = -1
                 gg = gg + 1
                 e_t(g+gg) = tend(k)              ! at same time as end of file
                 e_u(g+gg) = u
                 e_k(g+gg) = 0 
                 e_c(g+gg) = j
                 e_p1(g+gg) = i
                 e_p2(g+gg) = 0                    ! usual NoteOff velocity 
                 e_p3(g+gg) = 0.
                 e_f(g+gg) = k
                 e_r(g+gg) = e_r(h)           ! on same track as the NoteOn was
                 e_v(g+gg) = 0
                 e_g(g+gg) = -1
               END IF
             END DO                ! each MIDI note # 
           END DO                ! each channel           
         END IF      !   strict note Off/On checking ?
         
         g = g + gg
         f = f + L
       END DO               ! per-file loop
       
*-----------------------------------------------------------------------
*                 delete zero-duration notes
*-----------------------------------------------------------------------
       IF (.NOT. opt_N) THEN
         DO i = 1, g
           IF (e_k(i) .EQ. 1 .AND. e_p3(i) .LE. 0.) e_k(i) = 99
         END DO
       END IF
              
*-----------------------------------------------------------------------
*              finish together
*-----------------------------------------------------------------------
       IF (opt_f) THEN
         t = 0.                        ! harmonic mean final time
         n = 0
         DO k = 1, n_file
           IF (tend(k) > 0.0001) THEN
             t = t + 1. / tend(k)
             n = n + 1
           END IF
         END DO
         IF (t > 0.) THEN
           t = FLOAT(n) / t
         ELSE
           t = 0.0001
         END IF
         
*               for each file's events         
         DO k = 1, n_file
           IF (tend(k) > 0.0001) THEN
             factor = t / tend(k)
             DO i = 1, g
               IF (e_f(i) .EQ. k) e_t(i) = e_t(i) * factor
             END DO
           END IF
           tend(k) = t
         END DO
       END IF      ! option "F"
       
*-----------------------------------------------------------------------
*                  final time
*-----------------------------------------------------------------------
       tf = 0.
       DO k = 1, n_file
         tf = MAX(tf, tend(k))
       END DO
       
       eact = g                  ! actual # events returned
       
*          # events of any kind on any track
       kul = 0
       DO j = 1, mnr
         DO i = 1, n_kind
           kul = MAX(kul, kuse(i,j))
         END DO
       END DO
       RETURN
      END ! of RMIDI


*-----------------------------------------------------------------------
* WMIDI - write from a data structure out to a Standard MIDI file
*-----------------------------------------------------------------------
*                              I/O LIST
*__Name_________________Type___________I/O____Description_______________
*  buf[Ltot]            INTEGER*1      in     all the input
*  Ltot                 INTEGER        in     length of buf[]
*  f_name               CHARACTER*256  in     output filename
*  n_trk                INTEGER        in     number of tracks
*  etot                 INTEGER        in     count of all events
*  e_s[etot]            INTEGER        work   event times in ticks
*  e_t[etot]            REAL           in     event times [seconds]
*  e_k[etot]            INTEGER        in     event kind 
*  e_c[etot]            INTEGER        in     event channel
*  e_p1[etot]           INTEGER        in     event parameter 1
*  e_p2[etot]           INTEGER        in     event parameter 2
*  e_p3[etot]           REAL           in     event parameter 3
*  e_v[etot]            INTEGER        in     note off velocity
*  e_g[etot]            INTEGER        in     note portamento prefix
*  e_r[etot]            INTEGER        in     event tracks
*  e_o[etot]            INTEGER        work   event sort order codes
*  ind[etot]            INTEGER        work   index array
*  RSW[3@etot]          REAL           work   for merge sort
*  JSW[3@etot]          INTEGER        work     "      "
*  usehrv               LOGICAL        in     write hi-res velocity
*  fault                INTEGER        out    error code 0=no errors
*
*-----------------------------------------------------------------------
      SUBROUTINE WMIDI (buf, Ltot, f_name, n_trk, etot,  
     &  e_s, e_t, e_k, e_c, e_p1, e_p2, e_p3, e_v, e_g, e_r, e_o, ind, 
     &  RSW, JSW, usehrv, fault)
      
       IMPLICIT NONE
       INTEGER Ltot, n_trk, etot, e_s, e_k, e_c, e_p1, e_p2, e_v, e_g, 
     &   e_r, e_o, ind, JSW, fault
       INTEGER*1 buf
       REAL e_t, e_p3, RSW
       CHARACTER*256 f_name
       LOGICAL usehrv !, opt_w
       DIMENSION    buf(Ltot), e_s(etot), e_t(etot), e_k(etot), 
     &  e_c(etot), e_p1(etot), e_p2(etot), e_p3(etot), e_v(etot), 
     &  e_g(etot), e_r(etot), e_o(etot), ind(etot), 
     &  RSW(3*etot), JSW(3*etot)

*           local variables
       INTEGER n_kind 
       PARAMETER (n_kind = 90)
       INTEGER*1 
     &           b, c, d,             ! single bytes
     &           mthd(8), mtrk(4),    ! constants 
     &           null,                !
     &           varb(4)              ! a delta-time
     
       INTEGER
     &           g,                    ! count events
     &           h,                    ! misc. counter
     &           i,                    ! file position
     &           IOU,                  ! a file I/O Unit
     &           j,                    ! count tracks
     &           kind,                 ! what kind of event
     &           L,                    ! position to write track length at
     &           m,                    ! temporary integer
     &           n,                    ! length of track data
     &           p,                    ! number of data bytes in an event
     &           prior(0:n_kind),      ! priority of event kinds
     &           s, sprev              ! ticks elapsed so far
     
       REAL
     &      fps,                          ! frames per second
     &      offset,                       ! SMPTE offset, seconds
     &      tps,                          ! ticks per second
     &      t, tprev                      ! elapsed time
     
*            External functions
       INTEGER
     &           BITSZ,                ! Same as BIT_SIZE
     &           IOUNIT,               ! get a valid I/O Unit
     &           WVARB                 ! Write variable byte quantity
 
*           Constants  
       INTEGER div, fr, mnome, n32pqn
       PARAMETER (div = 480,         ! timing resolution in ticks per Q.N.
     &            fr = 3,       ! int to select frame rate in SMPTE (=> 30 f/s)
     &            mnome = 24,        ! MIDI clocks per metronome tick
     &            n32pqn = 8)        ! number of 32nd notes in a quarter note
       SAVE mthd, mtrk, null, prior
       DATA mthd / 77, 84, 104, 100, 0, 0, 0, 6 /
       DATA mtrk / 77, 84, 114, 107 /
       DATA null / 0 /
       
*-----------------------------------------------------------------------
* priorities for simultaneous events:
* 0  meta-events, system exclusive
* 1  note off
* 2  controllers, patch change, channel pressure, pitch bend, parameter change
* 3  note on   
*-----------------------------------------------------------------------
       DATA prior / 1,                                  !  0
     &              3, 2, 2, 2, 2, 2, 2, 2, 2, 2,       !  1 ... 10
     &              2, 2, 2, 2, 2, 2, 2, 2, 2, 2,       ! 11 ... 20
     &              2, 2, 2, 2, 2, 2, 2, 2, 2, 2,       ! 21 ... 30
     &              2, 2, 2, 2, 2, 2, 2, 2, 2, 2,       ! 31 ... 40
     &              2, 2, 2, 2, 2, 2, 2, 2, 2, 2,       ! 41 ... 50
     &              2, 2, 2, 2, 2, 2, 2, 0, 0, 0,       ! 51 ... 60
     &              0, 0, 0, 0, 0, 0, 0, 0, 0, 0,       ! 61 ... 70
     &              0, 0, 0, 0, 0, 2, 2, 2, 2, 2,       ! 71 ... 80
     &              2, 2, 2, 2, 2, 2, 2, 2, 2, 2 /      ! 81 ... 90
    
*-----------------------------------------------------------------------
*        begin
*-----------------------------------------------------------------------
       fault = 0
       
*               sort by kind priority
       DO i = 1, etot
         h = e_k(i)
         IF (h .GE. 0 .AND. h .LE. n_kind) THEN
           e_o(i) = prior(h)             ! assign priority
         ELSE
           e_o(i) = 3               ! arbitrary !
         END IF
         ind(i) = i
       END DO
       CALL RSORTI (e_o, ind, etot, 2, JSW)
       CALL RORDER (e_t, ind, etot)
       CALL IORDER (e_k, ind, etot)
       CALL IORDER (e_c, ind, etot)
       CALL IORDER (e_p1, ind, etot)
       CALL IORDER (e_p2, ind, etot)
       CALL RORDER (e_p3, ind, etot)
       CALL IORDER (e_v, ind, etot)
       CALL IORDER (e_g, ind, etot)
       CALL IORDER (e_r, ind, etot)
       
*               sort by time
       DO i = 1, etot 
         ind(i) = i 
       END DO
       CALL MSORTR (e_t, ind, etot, RSW, JSW)
       CALL IORDER (e_k, ind, etot)
       CALL IORDER (e_c, ind, etot)
       CALL IORDER (e_p1, ind, etot)
       CALL IORDER (e_p2, ind, etot)
       CALL RORDER (e_p3, ind, etot)
       CALL IORDER (e_v, ind, etot)
       CALL IORDER (e_g, ind, etot)
       CALL IORDER (e_r, ind, etot)
       
*               convert times to ticks
       s = 0 
       t = 0.
       tps = 2.0 * div        ! 120 bpm
       DO i = 1, etot
         tprev = t
         t = e_t(i)
         s = s + NINT((t - tprev) * tps)
         e_s(i) = s
         IF (e_k(i) .EQ. 70) tps = e_p3(i) * div     ! change tempo
       END DO
                 
*              sort by track
       IF (n_trk > 0) THEN
         m = BITSZ()
         DO WHILE (.NOT. BTEST(n_trk, m-1))   ! find significant bits of n_trk
           m = m - 1
         END DO
       ELSE
         m = 1
       END IF
       DO i = 1, etot 
         ind(i) = i 
       END DO
       CALL RSORTI (e_r, ind, etot, m, JSW)
       CALL IORDER (e_s, ind, etot)
       CALL IORDER (e_k, ind, etot)
       CALL IORDER (e_c, ind, etot)
       CALL IORDER (e_p1, ind, etot)
       CALL IORDER (e_p2, ind, etot)
       CALL RORDER (e_p3, ind, etot)
       CALL IORDER (e_v, ind, etot)
       CALL IORDER (e_g, ind, etot)
         
*-----------------------------------------------------------------------
*               file I/O         
*-----------------------------------------------------------------------
       IOU = IOUNIT()
       OPEN (UNIT=IOU, FILE=f_name, ACCESS='DIRECT', RECL=1, 
     &     FORM='UNFORMATTED', STATUS='NEW', IOSTAT=fault)
         IF (fault .NE. 0) PRINT *, 'trouble opening file ', f_name
         
*                     write the header         
       DO i = 1, 8
         WRITE (UNIT=IOU, REC=i, ERR=90) mthd(i)
       END DO

*                     file format / type
       b = 0
       IF (n_trk .EQ. 1) THEN
         c = 0
       ELSE IF (n_trk > 1 .AND. n_trk < 65536) THEN 
         c = 1
       ELSE
         fault = -6
         PRINT *, 'WMIDI:  bad number of tracks'
         RETURN
       END IF        
       WRITE (UNIT=IOU, REC=9, ERR=90) b
       WRITE (UNIT=IOU, REC=10, ERR=90) c
                  
*                      number of tracks
       CALL BYTPUT(b, n_trk, 1)
       CALL BYTPUT(c, n_trk, 0)
       WRITE (UNIT=IOU, REC=11, ERR=90) b
       WRITE (UNIT=IOU, REC=12, ERR=90) c
       
*                       time division
       CALL BYTPUT(b, div, 1)
       CALL BYTPUT(c, div, 0)
       WRITE (UNIT=IOU, REC=13, ERR=90) b
       WRITE (UNIT=IOU, REC=14, ERR=90) c

*-----------------------------------------------------------------------
*            for each track
*-----------------------------------------------------------------------
       i = 14      ! at end of file header
       g = 0       ! no events processed
       
       DO 60 j = 1, n_trk
         DO h = 1, 4             ! write 'MTrk'
           i = i + 1
           WRITE (UNIT=IOU, REC=i, ERR=90) mtrk(h)
         END DO               
           
*           remember file position for track length
         L = i
         i = i + 4              ! skip ahead
           
*-----------------------------------------------------------------------
*            process events
*-----------------------------------------------------------------------
         s = 0                      ! at beginning
         
         DO 40 WHILE (.TRUE.)          ! for all events in track
           IF (g+1 > etot) GO TO 50       ! and write end-of-track
           IF (e_r(g+1) .NE. j) GO TO 50     ! if next track
           g = g + 1
           
*               what kind of event
           kind = e_k(g)
           IF (kind .EQ. 99) GO TO 40            ! non-event
                        
*-----------------------------------------------------------------------
*                 write delta-time
*-----------------------------------------------------------------------
           sprev = s
           s = e_s(g)
           m = s - sprev
           p = WVARB(m, varb)           ! convert to variable bytes
           IF (p .EQ. -1) PRINT *, 'cant convert delta time of ', m
           DO h = 1, p
             i = i + 1
             WRITE (UNIT=IOU, REC=i, ERR=90) varb(h)
           END DO
                         
*-----------------------------------------------------------------------
*               write the various events
*-----------------------------------------------------------------------

*-----------------------------------------------------------------------
*               NoteOff
*-----------------------------------------------------------------------
           IF (kind .EQ. 0) THEN
             m = IBITS(e_p2(g), 0, 7)    ! velocity LSB
             IF (usehrv .AND. m .NE. 0) THEN       ! hi-res velocity
               CALL BYTPUT (d, m, 0)
               m = IOR(176, e_c(g))
               CALL BYTPUT (b, m, 0)
               c = 88
               WRITE (UNIT=IOU, REC=i+1, ERR=90) b
               WRITE (UNIT=IOU, REC=i+2, ERR=90) c
               WRITE (UNIT=IOU, REC=i+3, ERR=90) d
               WRITE (UNIT=IOU, REC=i+4, ERR=90) null       ! zero delta-time
               i = i + 4
             END IF

             m = IOR(128, e_c(g))
             CALL BYTPUT (b, m, 0)          ! status byte
             CALL BYTPUT (c, e_p1(g), 0)     ! note #
             m = IBITS(e_p2(g), 7, 7)          
             CALL BYTPUT (d, m, 0)           ! velocity MSB
             
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3
             
*-----------------------------------------------------------------------
*               NoteOn
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 1) THEN
             IF (e_g(g) .GE. 0) THEN         ! portamento prefix
               m = IOR(176, e_c(g))      ! controller status
               CALL BYTPUT (b, m, 0)
               c = 84                       ! portamento controller
               CALL BYTPUT (d, e_g(g), 0)
               WRITE (UNIT=IOU, REC=i+1, ERR=90) b
               WRITE (UNIT=IOU, REC=i+2, ERR=90) c
               WRITE (UNIT=IOU, REC=i+3, ERR=90) d
               WRITE (UNIT=IOU, REC=i+4, ERR=90) null     ! zero delta time
               i = i + 4
             END IF
             m = IBITS(e_p2(g), 0, 7)   ! velocity LSB
             IF (usehrv .AND. m .NE. 0) THEN         ! hi-res velocity
               CALL BYTPUT (d, m, 0)
               m = IOR(176, e_c(g))    ! controller status
               CALL BYTPUT (b, m, 0)
               c = 88
               WRITE (UNIT=IOU, REC=i+1, ERR=90) b
               WRITE (UNIT=IOU, REC=i+2, ERR=90) c
               WRITE (UNIT=IOU, REC=i+3, ERR=90) d
               WRITE (UNIT=IOU, REC=i+4, ERR=90) null   ! zero delta time
               i = i + 4
             END IF
             m = IOR(144, e_c(g))
             CALL BYTPUT (b, m, 0)        ! status byte
             CALL BYTPUT (c, e_p1(g), 0)   ! note #
             m = IBITS(e_p2(g), 7, 7)      
             CALL BYTPUT (d, m, 0)          ! velocity MSB
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3
             
*-----------------------------------------------------------------------
*             Aftertouch 
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 2) THEN
             m = IOR(160, e_c(g))                     ! status
             CALL BYTPUT (b, m, 0)            
             CALL BYTPUT (c, e_p1(g), 0)               ! note #
             CALL BYTPUT (d, e_p2(g), 0)                ! velocity
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3              
             
*-----------------------------------------------------------------------
*                  Controllers
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 3) THEN            ! bank select
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 0                                 ! coarse adjust
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 32                                ! fine adjust
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null      ! delta-time 0
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
             
           ELSE IF (kind .EQ. 4) THEN                ! wheel
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 1                                    ! coarse
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 33                                ! fine adjust
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null      ! delta-time 0
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7

           ELSE IF (kind .EQ. 5) THEN                ! breath
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 2                                    ! coarse
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 34                                ! fine adjust
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null      ! delta-time 0
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
             
           ELSE IF (kind .EQ. 6) THEN                ! foot
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 4                                    ! coarse
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 36                                ! fine adjust
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null      ! delta-time 0
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
             
           ELSE IF (kind .EQ. 7) THEN                ! portamento rate
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 5                                    ! coarse
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 37                                ! fine adjust
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null      ! delta-time 0
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
           
           ELSE IF (kind .EQ. 8) THEN                  ! shouldn't happen
             PRINT *, 'WMIDI: slider event in input!'
             fault = -1
             
           ELSE IF (kind .EQ. 9) THEN              ! volume
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 7
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             IF (d < 0) THEN 
               PRINT *, 'WMIDI: negative volume!'
               fault = 3
             END IF
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 39
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
             
           ELSE IF (kind .EQ. 10) THEN               ! balance
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 8
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             IF (d < 0) THEN 
               PRINT *, 'WMIDI: negative balance!'
               fault = 3
             END IF
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 40
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
             
           ELSE IF (kind .EQ. 11) THEN              ! pan
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 10
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             IF (d < 0) THEN 
               PRINT *, 'WMIDI: negative pan!'
               fault = 3
             END IF
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 42
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
             
           ELSE IF (kind .EQ. 12) THEN              ! expression
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 11
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             IF (d < 0) THEN 
               PRINT *, 'WMIDI: negative expression!'
               fault = 3
             END IF
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 43
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
            
           ELSE IF (kind .EQ. 13) THEN          ! effect #1, whatever that is
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 12                                    ! coarse
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 44                                ! fine adjust
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null      ! delta-time 0
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
     
           ELSE IF (kind .EQ. 14) THEN          ! effect #2
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 13                                    ! coarse
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 45                                ! fine adjust
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null      ! delta-time 0
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
           
           ELSE IF (kind .EQ. 15) THEN              ! general purpose #1
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 16
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 48                                ! fine adjust
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null      ! delta-time 0
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
     
           ELSE IF (kind .EQ. 16) THEN               ! general purpose #2
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 17
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 49                                ! fine adjust
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null      ! delta-time 0
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
  
           ELSE IF (kind .EQ. 17) THEN               ! general purpose #3
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 18
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 50                                ! fine adjust
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null      ! delta-time 0
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
              
           ELSE IF (kind .EQ. 18) THEN              ! general purpose #4
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 19
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 51                                ! fine adjust
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null      ! delta-time 0
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             i = i + 7
             
           ELSE IF (kind .GE. 19 .AND. kind .LE. 24) THEN  ! off/on switches
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             m = kind + 45
             CALL BYTPUT (c, m, 0)
             IF (e_p1(g) < 64) THEN
               d = 0
             ELSE
               d = 127
             END IF
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3
           
           ELSE IF (kind .GE. 25 .AND. kind .LE. 38) THEN  ! misc. controls
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             m = kind + 45
             CALL BYTPUT (c, m, 0)
             CALL BYTPUT (d, e_p1(g), 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3
            
           ELSE IF (kind .EQ. 39) THEN
             PRINT *, 'WMIDI: portamento control in input'
             fault = -39
             
           ELSE IF (kind .EQ. 40) THEN
             PRINT *, 'WMIDI: hi-res velocity control in input'
             fault = -40
             
           ELSE IF (kind .GE. 41 .AND. kind .LE. 45) THEN
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)             
             m = kind + 50
             CALL BYTPUT (c, m, 0)           
             CALL BYTPUT (d, e_p1(g), 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3
             
           ELSE IF (kind .EQ. 46) THEN            ! this is an error
             PRINT *, 'WMIDI:  button increment event in input'
             fault = -1
             
           ELSE IF (kind .EQ. 47) THEN           ! NRPN
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 99
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)           
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 98
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT(d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             c = 6
             m = IBITS(e_p2(g), 7, 7)
             CALL BYTPUT (d, m, 0)           
             WRITE (UNIT=IOU, REC=i+8, ERR=90) null
             WRITE (UNIT=IOU, REC=i+9, ERR=90) b
             WRITE (UNIT=IOU, REC=i+10, ERR=90) c
             WRITE (UNIT=IOU, REC=i+11, ERR=90) d
             c = 38
             m = IBITS(e_p2(g), 0, 7)
             CALL BYTPUT(d, m, 0)
             WRITE (UNIT=IOU, REC=i+12, ERR=90) null
             WRITE (UNIT=IOU, REC=i+13, ERR=90) b
             WRITE (UNIT=IOU, REC=i+14, ERR=90) c
             WRITE (UNIT=IOU, REC=i+15, ERR=90) d
             i = i + 15
                         
           ELSE IF (kind .EQ. 48) THEN
             PRINT *, 'WMIDI:  registered parameter number in input'
             fault = -1
             
           ELSE IF (kind .EQ. 49) THEN              ! all sound off
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 120
             d = 0
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3
           
           ELSE IF (kind .EQ. 50) THEN            ! all controllers off
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 121
             d = 0
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3

           ELSE IF (kind .EQ. 51) THEN                 ! local keyboard off/on
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 122
             IF (e_p1(g) < 64) THEN
               d = 0
             ELSE
               d = 127
             END IF
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3
                            
           ELSE IF (kind .EQ. 52) THEN             ! all notes off
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 123
             d = 0
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3

           ELSE IF (kind .EQ. 53) THEN            ! Omni off/on
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             IF (e_p1(g) .EQ. 0) THEN
               c = 124                             ! omni off
             ELSE IF (e_p1(g) .EQ. 127) THEN
               c = 125                             ! omni on
             ELSE
               PRINT *, 'WMIDI: bad omni off/on value'
               fault = 6
             END IF
             d = 0
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3
  
           ELSE IF (kind .EQ. 54) THEN        ! Mono / Poly mode
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             IF (e_p1(g) .EQ. 0) THEN           ! mono mode
               c = 126
               CALL BYTPUT (d, e_p2(g), 0)
             ELSE IF (e_p1(g) .EQ. 127) THEN       ! poly mode
               c = 127
               d = 0
             ELSE 
               PRINT *, 'WMIDI: bad mono/poly value'
               fault = 6
             END IF
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3
             
*-----------------------------------------------------------------------
*               patch change                 
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 55) THEN
             m = IOR(192, e_c(g))
             CALL BYTPUT (b, m, 0)
             CALL BYTPUT (c, e_p1(g), 0)             ! patch
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             i = i + 2 
             
*-----------------------------------------------------------------------
*                channel pressure
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 56) THEN 
             m = IOR(208, e_c(g))
             CALL BYTPUT (b, m, 0)                 ! status byte
             CALL BYTPUT (c, e_p1(g), 0)                ! pressure
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             i = i + 2
             
*-----------------------------------------------------------------------
*               pitch bend
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 57) THEN
             m = IOR(224, e_c(g))
             CALL BYTPUT (b, m, 0)
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (c, m, 0)
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             i = i + 3
             
*-----------------------------------------------------------------------
*                System Exclusive
*-----------------------------------------------------------------------
           ELSE IF (kind .EQ. 58 .OR. kind .EQ. 59) THEN
             IF (n_trk .EQ. 1) THEN             ! write channel prefix
               b = -1             ! meta
               c = 32              ! kind
               d = 1                ! length
               WRITE (UNIT=IOU, REC=i+1, ERR=90) b
               WRITE (UNIT=IOU, REC=i+2, ERR=90) c
               WRITE (UNIT=IOU, REC=i+3, ERR=90) d
               CALL BYTPUT (b, e_c(g), 0)
               WRITE (UNIT=IOU, REC=i+4, ERR=90) b
               WRITE (UNIT=IOU, REC=i+5, ERR=90) null    ! delta time for next
               i = i + 5
             END IF

             IF (kind .EQ. 58) THEN
               b = -16
             ELSE 
               b = -9
             END IF
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b        ! status byte
             i = i + 1
             m = e_p2(g)
             p = WVARB(m, varb)
             IF (p .EQ. -1) PRINT *, 'cant convert sysex len ', m
             DO h = 1, p                       ! write length
               i = i + 1
               WRITE (UNIT=IOU, REC=i, ERR=90) varb(h)
             END DO
             p = e_p1(g)                        ! pointer
             DO h = 1, m                         ! write blob

*                bounds check 
               IF (p+h-1 .LE. Ltot) THEN
                 i = i + 1
                 b = buf(p+h-1)
                 WRITE (UNIT=IOU, REC=i, ERR=90) b
               ELSE
                 PRINT *, 'WMIDI: tried to read past buffer!',
     &             ' p= ', P, ' h= ', H, 'g= ', G, ' p1: ', e_p1(g), 
     &             ' p2: ', e_p2(g)
               END IF
             END DO
           
*-----------------------------------------------------------------------
*                 meta events
*----------------------------------------------------------------------- 
           ELSE IF (kind .EQ. 60) THEN       ! channel prefix, sequence number
             IF (n_trk .EQ. 1) THEN             ! useful only for type 0 files
               b = -1             ! meta
               c = 32              ! kind
               d = 1                ! length
               WRITE (UNIT=IOU, REC=i+1, ERR=90) b
               WRITE (UNIT=IOU, REC=i+2, ERR=90) c
               WRITE (UNIT=IOU, REC=i+3, ERR=90) d
               CALL BYTPUT (b, e_c(g), 0)
               WRITE (UNIT=IOU, REC=i+4, ERR=90) b
               WRITE (UNIT=IOU, REC=i+5, ERR=90) null    ! delta time for next
               i = i + 5
             END IF
             
             b = -1           ! meta               ! sequence #
             c = 0             ! kind
             d = 2               ! length
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             CALL BYTPUT(b, e_p1(g), 1)
             CALL BYTPUT(c, e_p1(g), 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) b
             WRITE (UNIT=IOU, REC=i+5, ERR=90) c
             i = i + 5
               
*----------------------------------------------------------------------- 
*                          text-type events               
*----------------------------------------------------------------------- 
           ELSE IF (kind .GE. 61 .AND. kind .LE. 69) THEN

             IF (n_trk .EQ. 1) THEN             ! channel prefix
               b = -1             ! meta
               c = 32              ! kind
               d = 1                ! length
               WRITE (UNIT=IOU, REC=i+1, ERR=90) b
               WRITE (UNIT=IOU, REC=i+2, ERR=90) c
               WRITE (UNIT=IOU, REC=i+3, ERR=90) d
               CALL BYTPUT (b, e_c(g), 0)
               WRITE (UNIT=IOU, REC=i+4, ERR=90) b
               WRITE (UNIT=IOU, REC=i+5, ERR=90) null ! delta time for next event
               i = i + 5
             END IF

             b = -1             ! meta
             m = kind - 60
             CALL BYTPUT (c, m, 0)
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             i = i + 2
             m = e_p2(g)
             p = WVARB(m, varb)
             IF (p .EQ. -1) PRINT *, 'cant convert text length ', m
             DO h = 1, p                               ! write length
               i = i + 1
               WRITE (UNIT=IOU, REC=i, ERR=90) varb(h)
             END DO
             p = e_p1(g)                              ! pointer
             DO h = 1, m                                ! write string
               
*               bounds check
               IF (p+h-1 .LE. Ltot) THEN               
                 i = i + 1
                 b = buf(p+h-1)
                 WRITE (UNIT=IOU, REC=i, ERR=90) b
               ELSE
                 PRINT *, 'WMIDI: tried to read past buffer!',
     &             ' p= ', P, ' h= ', H, 'g= ', G, ' p1: ', e_p1(g), 
     &             ' p2: ', e_p2(g)
               END IF
             END DO
             
*----------------------------------------------------------------------- 
*        schedule events:       tempo
*----------------------------------------------------------------------- 
           ELSE IF (kind .EQ. 70) THEN
             b = -1             ! meta
             c = 81              ! type
             d = 3                ! length
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             m = NINT(1 000 000. / e_p3(g))    ! microseconds per quarter note
             CALL BYTPUT(b, m, 2)
             CALL BYTPUT(c, m, 1)
             CALL BYTPUT(d, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) b
             WRITE (UNIT=IOU, REC=i+5, ERR=90) c
             WRITE (UNIT=IOU, REC=i+6, ERR=90) d
             i = i + 6
             
*                     SMPTE Offset
           ELSE IF (kind .EQ. 71) THEN
             IF (fr .EQ. 0) THEN
               fps = 24.
             ELSE IF (fr .EQ. 1) THEN
               fps = 25.
             ELSE IF (fr .EQ. 2) THEN
               fps = 29.97
             ELSE IF (fr .EQ. 3) THEN
               fps = 30.
             ELSE
               fault = -84
               PRINT *, 'WMIDI: bad frame rate!!'
               RETURN
             END IF
             b = -1
             c = 84
             d = 5
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             offset = e_p3(g)
             m = INT(offset / 3600.)              ! hours
             CALL MVBITS (fr, 0, 2, m, 5)         ! encode frame rate
             CALL BYTPUT (b, m, 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) b
             offset = MOD(offset, 3600.)
             m = INT(offset / 60.)                ! minutes
             CALL BYTPUT (b, m, 0)
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             offset = MOD(offset, 60.)
             m = INT(offset)                      ! seconds
             CALL BYTPUT (b, m, 0)
             WRITE (UNIT=IOU, REC=i+6, ERR=90) b
             offset = MOD(offset, 1.)
             m = INT(offset * fps)                ! frames
             CALL BYTPUT (b, m, 0)
             WRITE (UNIT=IOU, REC=i+7, ERR=90) b
             offset = MOD(offset, 1. / fps)
             m = INT(offset * fps * 100.)         ! 1/100th frames
             CALL BYTPUT (b, m, 0)
             WRITE (UNIT=IOU, REC=i+8, ERR=90) b
             i = i + 8
             
*                 time signature
           ELSE IF (kind .EQ. 72) THEN
             b = -1          ! meta
             c = 88            ! kind
             d = 4              ! length
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             CALL BYTPUT (b, e_p1(g), 0)
             CALL BYTPUT (c, e_p2(g), 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) b
             WRITE (UNIT=IOU, REC=i+5, ERR=90) c
             CALL BYTPUT (b, mnome, 0)
             CALL BYTPUT (c, n32pqn, 0)
             WRITE (UNIT=IOU, REC=i+6, ERR=90) b
             WRITE (UNIT=IOU, REC=i+7, ERR=90) c
             i = i + 7
              
*                 key signature
           ELSE IF (kind .EQ. 73) THEN
             b = -1                               ! meta
             c = 89                                 ! kind
             d = 2                                   ! length
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=+i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             CALL BYTPUT (b, e_p1(g), 0)
             CALL BYTPUT (c, e_p2(g), 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) b
             WRITE (UNIT=IOU, REC=i+5, ERR=90) c
             i = i + 5

*                 XMF patch type
           ELSE IF (kind .EQ. 74) THEN
             IF (n_trk .EQ. 1) THEN             ! write channel prefix
               b = -1             ! meta
               c = 32              ! kind
               d = 1                ! length
               WRITE (UNIT=IOU, REC=i+1, ERR=90) b
               WRITE (UNIT=IOU, REC=i+2, ERR=90) c
               WRITE (UNIT=IOU, REC=i+3, ERR=90) d
               CALL BYTPUT (b, e_c(g), 0)
               WRITE (UNIT=IOU, REC=i+4, ERR=90) b
               WRITE (UNIT=IOU, REC=i+5, ERR=90) null    ! delta time for next
               i = i + 5
             END IF
             b = -1                               ! meta
             c = 96                                 ! kind
             d = 1                                   ! length
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             CALL BYTPUT (b, e_p1(g), 0)
             WRITE (UNIT=IOU, REC=i+4, ERR=90) b
             i = i + 4

*                 sequencer specific meta-event
           ELSE IF (kind .EQ. 75) THEN
             IF (n_trk .EQ. 1) THEN             ! write channel prefix
               b = -1             ! meta
               c = 32              ! kind
               d = 1                ! length
               WRITE (UNIT=IOU, REC=i+1, ERR=90) b
               WRITE (UNIT=IOU, REC=i+2, ERR=90) c
               WRITE (UNIT=IOU, REC=i+3, ERR=90) d
               CALL BYTPUT (b, e_c(g), 0)
               WRITE (UNIT=IOU, REC=i+4, ERR=90) b
               WRITE (UNIT=IOU, REC=i+5, ERR=90) null    ! delta time for next
               i = i + 5
             END IF
             b = -1                               ! meta
             c = 127                                ! kind
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b        ! status byte
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c        ! meta type
             i = i + 2
             m = e_p2(g)
             p = WVARB(m, varb)
             IF (p .EQ. -1) PRINT *, 'cant convert seq spec len ', m
             DO h = 1, p                       ! write length
               i = i + 1
               WRITE (UNIT=IOU, REC=i, ERR=90) varb(h)
             END DO
             p = e_p1(g)                        ! pointer
             DO h = 1, m                         ! write blob
!                  bounds check
               IF (p+h-1 .LE. Ltot) THEN               
                 i = i + 1
                 b = buf(p+h-1)
                 WRITE (UNIT=IOU, REC=i, ERR=90) b
               ELSE
                 PRINT *, 'WMIDI: tried to read past buffer!',
     &             ' p= ', P, ' h= ', H, 'g= ', G, ' p1: ', e_p1(g), 
     &             ' p2: ', e_p2(g)
               END IF
             END DO

*-----------------------------------------------------------------------
*                       registered  parameters  
*-----------------------------------------------------------------------
*                  pitch bend range
           ELSE IF (kind .EQ. 76) THEN
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 101                          ! coarse adjust
             d = 0                             
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 100                            ! fine adjust
             d = 0
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null   ! delta-time
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             c = 6                                      ! slider
             m = e_p1(g) / 100
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+8, ERR=90) null
             WRITE (UNIT=IOU, REC=i+9, ERR=90) b
             WRITE (UNIT=IOU, REC=i+10, ERR=90) c
             WRITE (UNIT=IOU, REC=i+11, ERR=90) d
             c = 38
             m = MOD(e_p1(g), 100)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+12, ERR=90) null
             WRITE (UNIT=IOU, REC=i+13, ERR=90) b
             WRITE (UNIT=IOU, REC=i+14, ERR=90) c
             WRITE (UNIT=IOU, REC=i+15, ERR=90) d
             i = i + 15
             
*                     fine tuning
           ELSE IF (kind .EQ. 77) THEN   
             CALL BYTPUT(b, e_c(g), 0)
             c = -80
             b = IOR(b, c)
             c = 101                          ! coarse adjust
             d = 0                             
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 100                            ! fine adjust
             d = 1
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null   ! delta-time
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             c = 6                                      ! slider
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+8, ERR=90) null
             WRITE (UNIT=IOU, REC=i+9, ERR=90) b
             WRITE (UNIT=IOU, REC=i+10, ERR=90) c
             WRITE (UNIT=IOU, REC=i+11, ERR=90) d
             c = 38
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+12, ERR=90) null
             WRITE (UNIT=IOU, REC=i+13, ERR=90) b
             WRITE (UNIT=IOU, REC=i+14, ERR=90) c
             WRITE (UNIT=IOU, REC=i+15, ERR=90) d
             i = i + 15

*                 coarse tuning, tuning program, tuning bank              
           ELSE IF (kind .EQ. 78 .OR. 
     &                kind .EQ. 79 .OR. kind .EQ. 80) THEN
             CALL BYTPUT(b, e_c(g), 0)      ! send the RPN
             c = -80
             b = IOR(b, c)
             c = 101                          ! coarse adjust
             d = 0                             
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 100                            ! fine adjust
             IF (kind .EQ. 78) THEN
               d = 2
             ELSE IF (kind .EQ. 79) THEN
               d = 3
             ELSE IF (kind .EQ. 80) THEN
               d = 4
             ELSE
               fault = -80
               RETURN
             END IF
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null   ! delta-time
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             c = 6                                      ! slider
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+8, ERR=90) null
             WRITE (UNIT=IOU, REC=i+9, ERR=90) b
             WRITE (UNIT=IOU, REC=i+10, ERR=90) c
             WRITE (UNIT=IOU, REC=i+11, ERR=90) d
             i = i + 11
             
*                   mod depth range
           ELSE IF (kind .EQ. 81) THEN   
             CALL BYTPUT(b, e_c(g), 0)
             c = -80
             b = IOR(b, c)
             c = 101                          ! coarse adjust
             d = 0                             
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 100                            ! fine adjust
             d = 5
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null   ! delta-time
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             c = 6                                      ! slider
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+8, ERR=90) null
             WRITE (UNIT=IOU, REC=i+9, ERR=90) b
             WRITE (UNIT=IOU, REC=i+10, ERR=90) c
             WRITE (UNIT=IOU, REC=i+11, ERR=90) d
             c = 38
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+12, ERR=90) null
             WRITE (UNIT=IOU, REC=i+13, ERR=90) b
             WRITE (UNIT=IOU, REC=i+14, ERR=90) c
             WRITE (UNIT=IOU, REC=i+15, ERR=90) d
             i = i + 15

*                 3-d controllers
           ELSE IF (kind .GE. 82 .AND. kind .LE. 90) THEN
             m = IOR(176, e_c(g))
             CALL BYTPUT (b, m, 0)
             c = 101
             d = 61
             WRITE (UNIT=IOU, REC=i+1, ERR=90) b
             WRITE (UNIT=IOU, REC=i+2, ERR=90) c
             WRITE (UNIT=IOU, REC=i+3, ERR=90) d
             c = 100
             IF (kind .EQ. 82) THEN
               d = 0
             ELSE IF (kind .EQ. 83) THEN
               d = 1
             ELSE IF (kind .EQ. 84) THEN
               d = 2
             ELSE IF (kind .EQ. 85) THEN
               d = 3
             ELSE IF (kind .EQ. 86) THEN
               d = 4
             ELSE IF (kind .EQ. 87) THEN
               d = 5
             ELSE IF (kind .EQ. 88) THEN
               d = 6
             ELSE IF (kind .EQ. 89) THEN
               d = 7
             ELSE IF (kind .EQ. 90) THEN
               d = 8
             ELSE 
               fault = -90
               RETURN
             END IF
             WRITE (UNIT=IOU, REC=i+4, ERR=90) null   ! delta-time
             WRITE (UNIT=IOU, REC=i+5, ERR=90) b
             WRITE (UNIT=IOU, REC=i+6, ERR=90) c
             WRITE (UNIT=IOU, REC=i+7, ERR=90) d
             c = 6                                      ! slider
             m = IBITS(e_p1(g), 7, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+8, ERR=90) null
             WRITE (UNIT=IOU, REC=i+9, ERR=90) b
             WRITE (UNIT=IOU, REC=i+10, ERR=90) c
             WRITE (UNIT=IOU, REC=i+11, ERR=90) d
             c = 38
             m = IBITS(e_p1(g), 0, 7)
             CALL BYTPUT (d, m, 0)
             WRITE (UNIT=IOU, REC=i+12, ERR=90) null
             WRITE (UNIT=IOU, REC=i+13, ERR=90) b
             WRITE (UNIT=IOU, REC=i+14, ERR=90) c
             WRITE (UNIT=IOU, REC=i+15, ERR=90) d
             i = i + 15
             
           ELSE IF (kind .EQ. 99) THEN
             CONTINUE                                 ! meant to be ignored
             
           ELSE 
             PRINT *, 'unrecognized event kind ', kind
             fault = -7
           END IF  ! kind of event
  40     CONTINUE  ! track events    
                   
*-----------------------------------------------------------------------
  50     CONTINUE  ! end of track
*-----------------------------------------------------------------------
         b = -1
         c = 47
         WRITE (UNIT=IOU, REC=i+1, ERR=90) null
         WRITE (UNIT=IOU, REC=i+2, ERR=90) b
         WRITE (UNIT=IOU, REC=i+3, ERR=90) c
         WRITE (UNIT=IOU, REC=i+4, ERR=90) null
         i = i + 4
           
*                 length of track events
         n = i - L - 4
         CALL BYTPUT(b, n, 3)
         WRITE (UNIT=IOU, REC=L+1, ERR=90) b
         CALL BYTPUT(b, n, 2)
         WRITE (UNIT=IOU, REC=L+2, ERR=90) b
         CALL BYTPUT(b, n, 1)
         WRITE (UNIT=IOU, REC=L+3, ERR=90) b
         CALL BYTPUT(b, n, 0)
         WRITE (UNIT=IOU, REC=L+4, ERR=90) b
         
  60   CONTINUE       ! next track

*                     done
       CLOSE (UNIT=IOU, IOSTAT=fault)
       IF (fault .NE. 0) PRINT *, 'WMIDI: trouble closing file'
       RETURN      ! success
       
*-----------------------------------------------------------------------
  90   CONTINUE         ! fatal file I/O errors
*-----------------------------------------------------------------------
       PRINT *, 'trouble writing to file ', f_name, ' position ', i
       fault = -8
       STOP 'unrecoverable error'
       
      END   ! of WMIDI      
 
 
*-----------------------------------------------------------------------
*     decode the value of a variable-byte sequence without reading past EOF
*-----------------------------------------------------------------------
      SUBROUTINE declen(buf, varb, i, o, L, n, p)
       IMPLICIT NONE
       INTEGER i, o, L, n, p
       INTEGER * 1 b, varb, buf
       DIMENSION buf(L), varb(4)
       INTEGER h, m, RVARB
       
       DO h = 1, 4
         i = i + 1 
         o = o + 1
         IF (i > L .OR. o > n) STOP 'read past end of track!'
         b = buf(i)
         varb(h) = b
         IF (.NOT. BTEST(b, 7)) GO TO 50
       END DO
     
  50   p = RVARB(m, varb)
       IF (m .NE. h) PRINT *, 'declen: found ',m,' expected ',h
       RETURN
      END ! of declen


*-----------------------------------------------------------------------
*             reset state for fine-adjustable controllers
*-----------------------------------------------------------------------
*
*__Element______Description____________________________Units____________
*  spar[1]      Bank select                          14 bit value
*  spar[2]      Modulation wheel                      "      "
*  spar[3]      Breath control                        "      "
*  spar[4]      Foot control                          "      "
*  spar[5]      Portamento rate                       "      "
*  spar[6]      Data entry                            "      "
*  spar[7]      Volume                                "      "
*  spar[8]      Balance                               "      "
*  spar[9]      Pan                                   "      "
*  spar[10]     Expression                            "      "
*  spar[11]     Effect #1                             "      "
*  spar[12]     Effect #2                             "      "
*  spar[13]     General purpose #1                    "      "
*  spar[14]     General purpose #2                    "      "
*  spar[15]     General purpose #3                    "      "
*  spar[16]     General purpose #4                    "      "
*  spar[17]     RPN 0:  pitch bend range             cents
*  spar[18]     RPN 1:  channel fine tuning          14 bit value
*  spar[19]     RPN 2:  channel coarse tuning         7 bit value
*  spar[20]     RPN 3:  tuning program                "      "
*  spar[21]     RPN 4:  tuning bank                   "      "
*  spar[22]     RPN 5:  modulation depth range       14 bit value
*  spar[23]     RPN 7808:  azimuth angle              "      "
*  spar[24]     RPN 7809:  elevation angle            "      "
*  spar[25]     RPN 7810:  gain                       "      "
*  spar[26]     RPN 7811:  distance ratio             "      "
*  spar[27]     RPN 7812:  maximum distance           "      "
*  spar[28]     RPN 7813:  gain at maximum distance   "      "
*  spar[29]     RPN 7814:  reference angle ratio      "      "
*  spar[30]     RPN 7815:  pan spread angle           "      "
*  spar[31]     RPN 7816:  roll angle                 "      "
*-----------------------------------------------------------------------
      SUBROUTINE reset_ctl (spar, chan)
       IMPLICIT NONE
       INTEGER spar, chan
       DIMENSION spar(31,0:15)
       
*  Do not Reset: Bank Select, says Association of Music Electronics Industry
       spar(2,chan) = 0         ! set modulation to 0
       spar(3,chan) = 0
       spar(4,chan) = 0
       spar(5,chan) = 8192      ! center portamento rate
       spar(6,chan) = 0
*  Do not Reset:  Volume
       spar(8,chan) = 8192      ! center balance
*  Do not Reset:  Pan
       spar(10,chan) = 16383    ! full Expression      
       spar(11,chan) = 0        ! no Effect #1
       spar(12,chan) = 0  
       spar(13,chan) = 0        ! zero out general purpose
       spar(14,chan) = 0
       spar(15,chan) = 0
       spar(16,chan) = 0
       spar(17,chan) = 200      ! +/- 2 semitones
       spar(18,chan) = 8192     ! center fine tuning
       spar(19,chan) = 64       ! center coarse tuning
*        don't reset tuning program either
*        don't reset tuning bank
       spar(22,chan) = 8192      ! RPN 5 is in arbitrary units
       spar(23,chan) = 8192      ! 0 degrees
       spar(24,chan) = 8192      ! 0 degrees
       spar(25,chan) = 16383     ! max gain
       spar(26,chan) = 16        ! one meter 
       spar(27,chan) = 16383     ! 1 kilometer
       spar(28,chan) = 10383     ! -60 dB
       spar(29,chan) = 16        
       spar(30,chan) = 9557      ! 30 degrees
       spar(31,chan) = 8192      ! 0 degrees
       RETURN
      END  ! of reset_ctl


*-----------------------------------------------------------------------
*      Turn a variable-byte sequence into an integer, 
*           also return significant bytes in b
*-----------------------------------------------------------------------
      FUNCTION RVARB (b, var_bytes)       
       IMPLICIT NONE
       INTEGER*1 var_bytes 
       DIMENSION var_bytes(4)
       INTEGER b, m, n, RVARB
      
*        1 byte size
       n = IBITS(var_bytes(1), 0, 7)
       IF (.NOT. BTEST(var_bytes(1), 7)) THEN
         RVARB = n
         b = 1
         RETURN
       END IF

*        2 byte size
       n = ISHFT(n, 7)
       m = IBITS(var_bytes(2), 0, 7)
       n = IOR(m, n)       
       IF (.NOT. BTEST(var_bytes(2), 7)) THEN
         RVARB = n
         b = 2
         RETURN
       END IF
       
*        3 byte size
       n = ISHFT(n, 7)
       m = IBITS(var_bytes(3), 0, 7)
       n = IOR(m, n)
       IF (.NOT. BTEST(var_bytes(3), 7)) THEN
         RVARB = n
         b = 3
         RETURN
       END IF

*        4 byte size       
       n = ISHFT(n, 7)
       m = IBITS(var_bytes(4), 0, 7)
       n = IOR(m, n)
       RVARB = n
       b = 4
       RETURN
      END ! of RVARB


*-----------------------------------------------------------------------
*      Convert an integer to MIDI variable-byte format
*-----------------------------------------------------------------------
      FUNCTION WVARB (n, var_bytes)
       IMPLICIT NONE
       INTEGER n, WVARB
       INTEGER*1 var_bytes 
       DIMENSION var_bytes(4)

*           1 byte size
       IF (n .LE. 127) THEN
         var_bytes(1) = IAND(n, 127)
         WVARB = 1
         RETURN

*           2 byte size
       ELSE IF (n .LE. 16383) THEN
         var_bytes(1) = IBSET(ISHFT(IAND(n, 16256), -7), 7)
         var_bytes(2) = IAND(n, 127)
         WVARB = 2
         RETURN

*          3 byte size      
       ELSE IF (n .LE. 2097151) THEN
         var_bytes(1) = IBSET(ISHFT(IAND(n, 2080768), -14), 7)
         var_bytes(2) = IBSET(ISHFT(IAND(n, 16256), -7), 7)
         var_bytes(3) = IAND(n, 127)
         WVARB = 3
         RETURN
       
*          4 byte size       
       ELSE IF (n .LE. 268435455) THEN
         var_bytes(1) = IBSET(ISHFT(IAND(n, 266338304), -21), 7)
         var_bytes(2) = IBSET(ISHFT(IAND(n, 2080768), -14), 7)
         var_bytes(3) = IBSET(ISHFT(IAND(n, 16256), -7), 7)
         var_bytes(4) = IAND(n, 127)
         WVARB = 4
         RETURN

*          out of bounds
       ELSE
         PRINT *, 'number too large for variable-format'
       END IF
       WVARB = -1
       RETURN      
      END ! of WVARB


*:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*  copy 8 bits from a INTEGER*1 into a default INTEGER
*:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
      SUBROUTINE BYTGET (b, n, s)
       IMPLICIT NONE
       INTEGER*1 b
       INTEGER n, s
       INTEGER i     
       
       IF (s .EQ. 0) THEN
         DO i = 0, 7
           IF (BTEST(b, i)) THEN
             n = IBSET(n, i)
           ELSE
             n = IBCLR(n, i)
           END IF
         END DO
         
       ELSE IF (s .EQ. 1) THEN
         DO i = 0, 7
           IF (BTEST(b, i)) THEN
             n = IBSET(n, i + 8)
           ELSE
             n = IBCLR(n, i + 8)
           END IF
         END DO
         
       ELSE IF (s .EQ. 2) THEN
         DO i = 0, 7
           IF (BTEST(b, i)) THEN
             n = IBSET(n, i + 16)
           ELSE
             n = IBCLR(n, i + 16)
           END IF
         END DO
       
       ELSE IF (s .EQ. 3) THEN
         DO i = 0, 7
           IF (BTEST(b, i)) THEN
             n = IBSET(n, i + 24)
           ELSE
             n = IBCLR(n, i + 24)
           END IF
         END DO
         
       ELSE
         STOP 'bytget:  shift must be from 0 to 3'
       END IF
       
       RETURN
      END ! of BYTGET


*:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
*   copy 8 bits from a default INTEGER into an INTEGER*1
*:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
      SUBROUTINE BYTPUT (b, n, s)
       IMPLICIT NONE
       INTEGER*1 b
       INTEGER n, s
       INTEGER i     
       
       IF (s .EQ. 0) THEN
         DO i = 0, 7
           IF (BTEST(n, i)) THEN
             b = IBSET(b, i)
           ELSE
             b = IBCLR(b, i)
           END IF
         END DO
         
       ELSE IF (s .EQ. 1) THEN
         DO i = 0, 7
           IF (BTEST(n, i + 8)) THEN
             b = IBSET(b, i)
           ELSE
             b = IBCLR(b, i)
           END IF
         END DO
         
       ELSE IF (s .EQ. 2) THEN
         DO i = 0, 7
           IF (BTEST(n, i + 16)) THEN
             b = IBSET(b, i)
           ELSE
             b = IBCLR(b, i)
           END IF
         END DO
       
       ELSE IF (s .EQ. 3) THEN
         DO i = 0, 7
           IF (BTEST(n, i + 24)) THEN
             b = IBSET(b, i)
           ELSE
             b = IBCLR(b, i)
           END IF
         END DO
         
       ELSE
         STOP 'bytput:  shift must be from 0 to 3'
       END IF
       
       RETURN
      END ! of BYTPUT
*++++++++++++++++++++++ End of file midifile.f +++++++++++++++++++++++++
