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