*----------------------------------------------------------------------- * analyz - apply music analyis * by Andy Allinger, 2012-2016, released to the public domain * This program may be used by any person for any purpose. *----------------------------------------------------------------------- * I/O List *_Name______________Type______________I/O____Description________________ * uprofile[0:11, 0:1]REAL both frequency of pitches * ms DOUBLE PRECISION both sum of pitch difference * ms2 DOUBLE PRECISION both sum of square pitch difference * pkarr[0:127,0:127,0:11,0:1] REAL both probability matrix of prox & key * rpar[8] REAL both rhythm detection parameters * rsum[9] DOUBLE PRECISION both statistical totals for setting rpar * uprox[0:6] REAL both custom chord proximity * uqual[num_q,0:1] REAL both custom chord quality * uroot[0:11,0:1] REAL both custom chord root data * ccarr[num_q,0:11,0:11,0:1] REAL both frequency of chords given a chord * n INTEGER in allocate this many Note-Ons * NSTEPS INTEGER in number of rhythm eval. timepoints * NODES INTEGER in # of tempo spline interpolation pts * step REAL in duration of an evaluation step * tend REAL in time of last event * opt_G LOGICAL in genetic algorithm * opt_K LOGICAL in detect key signature * opt_L LOGICAL in long output * opt_P LOGICAL in split on counterpoint * opt_Q LOGICAL in quantize * opt_S LOGICAL in force single tempo * opt_T LOGICAL in detect tempo changes * opt_V LOGICAL in enhance velocity * getcfg LOGICAL in get configuration parameters * usecfg LOGICAL in load user's custom parameters * drum[0:15] LOGICAL in indicates drum channel(s) * e_t[e] REAL in times of events * e_k[e] INTEGER in event kinds * e_c[e] INTEGER in event channels (unused?) * e_p1[e] INTEGER in event data part 1 * e_p2[e] INTEGER in event data part 2 * e_p3[e] REAL in event data (duration or tempo) * e_v[e] INTEGER in note-off velocities * e_g[e] INTEGER in portamento prefixes * e_f[e] INTEGER in event source file * e_r[e] INTEGER in event track * e_u[e] REAL out event metrical times (in tactus) * ind[e] INTEGER work permutation vector * RSW[3@e] Real work for merge sort * JSW[3@e] Integer work for merge and radix sorts * e INTEGER in length of event list * ttmp[NSTEPS+1] REAL out onset time of a tempo change * thz[NSTEPS+1] REAL out frequency of a tempo change * nt INTEGER out number of tempo changes * avgtem REAL out average tempo * key_t[keylim] REAL out times of key changes * sharps[keylim] INTEGER out sharps in key signature * majmin[keylim] INTEGER out major or minor key * keylim Integer In array bound of key changes * nk INTEGER out number of detected key changes * p REAL out total log probability * psi[0:127,0:15] INTEGER work pointer to sound inception *----------------------------------------------------------------------- SUBROUTINE ANALYZ (uprofile, ms, ms2, pkarr, rpar, rsum, uprox, & uqual, uroot, ccarr, n, NSTEPS, NODES, step, tend, opt_G, opt_K, & opt_L, opt_P, opt_Q, opt_S, opt_T, opt_V, getcfg, usecfg, & drum, e_t, e_k, e_c, e_p1, e_p2, e_p3, e_v, e_g, e_f, e_r, & e_u, ind, RSW, JSW, e, ttmp, thz, nt, avgtem, key_t, sharps, & majmin, keylim, nk, p, psi) IMPLICIT NONE INTEGER NUM_Q, SOSC PARAMETER (NUM_Q = 15, ! match mixmidi.f, harmony.f & SOSC = 27) ! match rhythm.f INTEGER n, NSTEPS, NODES, e_k, e_c, e_p1, e_p2, e_v, e_g, & e_f, e_r, ind, JSW, e, nt, sharps, majmin, keylim, nk, psi REAL uprofile, pkarr, rpar, uprox, uqual, uroot, ccarr, & step, tend, e_t, e_p3, & e_u, RSW, ttmp, thz, avgtem, key_t, p DOUBLE PRECISION ms, ms2, rsum LOGICAL opt_G, opt_K, opt_L, opt_P, opt_Q, & opt_S, opt_T, opt_V, getcfg, usecfg, drum DIMENSION uprofile(0:11, 0:1), pkarr(0:127, 0:127, 0:11, 0:1), & rpar(8), rsum(9), uprox(0:6), uqual(num_q, 0:1), & uroot(0:11, 0:1), ccarr(num_q, 0:11, 0:11, 0:1), drum(0:15), & e_t(e), e_k(e), e_c(e), e_p1(e), e_p2(e), e_p3(e), e_v(e), & e_g(e), e_f(e), e_r(e), e_u(e), RSW(3*e), JSW(3*e), ind(e), & ttmp(NSTEPS+1), thz(NSTEPS+1), key_t(keylim), sharps(keylim), & majmin(keylim), psi(0:127, 0:15) * local variables INTEGER n_s, TL PARAMETER (n_s = 5, ! fewer strata than oscillators & TL = 3) ! index of the tactus level INTEGER PLIM, VLIM PARAMETER (PLIM = 24, $ VLIM = 10) INTEGER a, g, h, i, j, L, o, ! counters & c, ! # chord changes & cumw(2*n), ! sum of cumseg[0:11] each segment & fault, ! error code & ind0, indoff, indon, ! last negative index, last off, on & m, ! # rhythmic events & msv ! # streams made per puntal call INTEGER & nn, no, ! Note-Offs + Note-Ons, Note-Ons & nv, ! number of streams made & Q(2*n), R(2*n), ! chord qualities, roots & pall, ! # minimal partitions & pitseq(n), ! pitch sequence in a stream & PUNB(0:VLIM,2*N), PUNIND(PLIM,2*N+1), ! work arrays for PUNTAL & PUNNIV(2*N+1), PUNNOV(2*N+1), & qold, qnew, rold, rnew, ! prev, next chords & RHYB(SOSC,NSTEPS), RHYC(0:NSTEPS,n_s), ! work arrays for STRATA & shold, shnew, mmold, mmnew, ! prev, next keys & seg(0:11,2*n), cumseg(0:11,2*n), ! pitch vectors each segment & V(2*n) ! stream assignment each note REAL & accent(n), ! melodic accent of notes in stream & aff, aff0, ! fractal dimension (self-affinity) & beat(2*n,n_s), ! metrical time of each note in each stratum & CX(NODES+1), CY(NODES,n_s), ! phase curves for each stratum & CA(NODES,n_s), CB(NODES,n_s), CC(NODES,n_s), & ch_t(2*n), ! times of chord changes & dt, du, ! difference in time, in phase & e_w(e), ! instantaneous tempo each event & factor ! 1/tempo REAL & phar, prhy, pmel, paff, ! probabilities & partit(2*n), ! times of chord changes & PHI, ! a phase & pip, ! negligible duration & PUNTOF(2*N), ! work array for PUNTAL & RHYA(0:SOSC,0:NSTEPS,2), RHYP(0:SOSC,0:NSTEPS,2), ! for STRATA & RHYF(0:SOSC,0:NSTEPS,2), RHYW(0:NSTEPS), & RHYX(0:NSTEPS), RHYY(0:NSTEPS), RHYZ(7*NODES+25), & S(n), ! saliences of note events & T(n), ! times of note onsets & tau, tau1, ! decay of durational accent & timseq(n), ! onset time sequence in a stream & TX(NSTEPS+1), TA(NSTEPS+1), ! tempo curve coefficients & tprev, tnext ! times of events !! & tot ! a total REAL tarray(2), result, meltim, afftim ! speed of execution LOGICAL full, ! get all strata = opt_G or getcfg? & PUNLST(2*N+1) ! work array for PUNTAL CHARACTER job CHARACTER PUNCT(5) ! punctuation for a velocity class CHARACTER*2 keysig_name(-7:7, 0:1), ! one or two character name & SIG CHARACTER*3 tpc, spell(0:11, -7:7) ! spellings for different keys CHARACTER*5 quality_name(num_q) ! chord symbols CHARACTER*6 mmnam(0:1) ! major, minor CHARACTER*9 PHAA ! phase indicator bar CHARACTER*88 SCROLL * external functions INTEGER CEIL ! ceiling function REAL SNAP ! speedy exponential * Constants REAL DEFP, FAKPAR PARAMETER (DEFP = -9999., ! default log-probability !! $ eta = 1.1, ! a guess $ FAKPAR = 0.4) * The optimal saliences will depend on the particular song! REAL sal_vel, sal_dur, sal_har, sal_mel, ! salience coefficients & sal_bas, sal_dru, & whar, wmel, wrhy, waff ! importance weights PARAMETER (sal_bas = 0.10, ! salience of bass notes & sal_dru = 0.50, ! salience of drum events & sal_dur = 0.50, ! rhythmic salience of duration & sal_har = 0.05, ! rhythmic salience per chord change & sal_mel = 0.10, ! salience per melodic accent & sal_vel = 0.20, ! rhythmic salience per velocity & waff = 0.7, ! importance of affinity rating & whar = 0.8, ! importance of harmonic prob & wmel = 1.0, ! importance of melody prob & wrhy = 0.9) ! importance of rhythm prob SAVE punct, keysig_name, spell, quality_name, mmnam, pip, tau *----------------------------------------------------------------------- * select a punctuation mark to display in the piano roll view *----------------------------------------------------------------------- DATA PUNCT / ':', '|', '+', '*', '#' / *----------------------------------------------------------------------- * major and minor key-signature names *----------------------------------------------------------------------- DATA keysig_name / 'Cb', 'Gb', 'Db', 'Ab', 'Eb', 'Bb', 'F', & 'C', 'G', 'D', 'A', 'E', 'B', 'F#', 'C#', & 'Ab', 'Eb', 'Bb', 'F', 'C', 'G', 'D', 'A', 'E', 'B', 'F#', 'C#', & 'G#', 'D#', 'A#' / *----------------------------------------------------------------------- * tonal pitch class spellings, based on minimum distance on the line of fifths *----------------------------------------------------------------------- DATA spell / & 'Dbb','Db','Ebb','Eb','Fb','F','Gb','Abb','Ab','Bbb','Bb','Cb',! Cb & 'C','Db','Ebb','Eb','Fb','F','Gb','Abb','Ab','Bbb','Bb','Cb', ! Gb & 'C','Db','Ebb','Eb','Fb','F','Gb','G','Ab','Bbb','Bb','Cb', ! Db & 'C','Db','D','Eb','Fb','F','Gb','G','Ab','Bbb','Bb','Cb', ! Ab & 'C','Db','D','Eb','Fb','F','Gb','G','Ab','A','Bb','Cb', ! Eb & 'C','Db','D','Eb','E','F','Gb','G','Ab','A','Bb','Cb', ! Bb & 'C','Db','D','Eb','E','F','Gb','G','Ab','A','Bb','B', ! F & 'C','Db','D','Eb','E','F','F#','G','Ab','A','Bb','B', ! C & 'C','C#','D','Eb','E','F','F#','G','Ab','A','Bb','B', ! G & 'C','C#','D','Eb','E','F','F#','G','G#','A','Bb','B', ! D & 'C','C#','D','D#','E','F','F#','G','G#','A','Bb','B', ! A & 'C','C#','D','D#','E','F','F#','G','G#','A','A#','B', ! E & 'C','C#','D','D#','E','E#','F#','G','G#','A','A#','B', ! B & 'B#','C#','D','D#','E','E#','F#','G','G#','A','A#','B', ! F# & 'B#','C#','D','D#','E','E#','F#','F##','G#','A','A#','B' / ! C# *----------------------------------------------------------------------- * chord quality names - Make sure this list matches template[] in chordal *----------------------------------------------------------------------- DATA quality_name / & ' ', 'm', '7', 'maj7', 'm7', '6', 'm6', 'dim', & 'aug', 'dim7', '7-5', '7sus4', '9', '11', '13' / DATA mmnam / ' Major', ' Minor' / DATA pip, tau / 0.035, 0.5 / ! constant for durational accent *----------------------------------------------------------------------- * begin *----------------------------------------------------------------------- ! PRINT *, 'at analyz n=',n,' nsteps=',NSTEPS,' nodes=',NODES, ! $ ' tend=', tend, ' getcfg=', getcfg IF (N < 1) THEN PRINT *, 'analyz: nothing to do!' p = DEFP RETURN END IF !! PRINT *, 'event times: ', e_t CALL DTIME(tarray, result) !!! DEBUG:: DO i = 1, e IF (e_r(i) < 1) & PRINT*, 'analyz: negative track! ', e_r(i), ' at', i END DO * fill the key change array IF (.NOT. opt_K) THEN h = 0 DO i = 1, e IF (e_k(i) .EQ. 73) THEN h = h + 1 IF (h > keylim) THEN PRINT *, 'analyz: too many key changes!' EXIT END IF key_t(h) = e_t(i) sharps(h) = e_p1(i) majmin(h) = e_p2(i) END IF END DO nk = h END IF * mark drum events DO i = 1, e IF (drum(e_c(i))) THEN IF (e_k(i) .EQ. 0 .OR. e_k(i) .EQ. 1) THEN e_k(i) = e_k(i) - 2 ! thus {0,1} becomes {-2,-1} END IF END IF END DO * sort note events to the front DO i = 1, e ind(i) = i END DO CALL RSORTI (e_k, ind, e, -7, JSW) CALL RORDER (e_t, ind, e) CALL IORDER (e_c, ind, e) CALL IORDER (e_p1, ind, e) CALL IORDER (e_p2, ind, e) CALL RORDER (e_p3, ind, e) CALL IORDER (e_v, ind, e) CALL IORDER (e_g, ind, e) CALL IORDER (e_r, ind, e) CALL IBSLE(e_k, e, -1, ind0) ! last drum event CALL IBSLE(e_k, e, 0, indoff) ! last Note-Off CALL IBSLE(e_k, e, 1, indon) ! last Note-On nn = indon - ind0 ! Note-Ons and Note-Offs sans drums no = indon - indoff ! Note-Ons sans drums o = ind0 + 1 !!! DEBUG:: DO i = 1, nn IF (e_r(o+i-1) < 1) & PRINT*, 'after ks: negative track! ', e_r(o+i-1), ' at', o+i-1 END DO ! check count of notes! ! PRINT *, 'analyz: 2*n is ', 2*n, ' and nn is ', nn CALL DTIME(tarray, result) ! PRINT *, ' time fussing over input: ', tarray(1) *----------------------------------------------------------------------- * segregate streams *----------------------------------------------------------------------- * initialize all assignments to zero DO i = 1, 2*n V(i) = 0 END DO nv = 0 ! no voices yet * within non-drum Note_On and Note-Off, sort by time DO i = 1, nn ind(i) = i END DO CALL MSORTR (e_t(o), ind, nn, RSW, JSW) CALL IORDER (e_k(o), ind, nn) CALL IORDER (e_c(o), ind, nn) CALL IORDER (e_p1(o), ind, nn) CALL IORDER (e_p2(o), ind, nn) CALL RORDER (e_p3(o), ind, nn) CALL IORDER (e_v(o), ind, nn) CALL IORDER (e_g(o), ind, nn) CALL IORDER (e_r(o), ind, nn) !!! DEBUG:: DO i = 1, nn IF (e_r(o+i-1) < 1) & PRINT*, 'after ts: negative track! ', e_r(o+i-1), ' at', o+i-1 END DO * within non-drum Note-On & Note-Off, sort by track DO i = 1, nn ind(i) = i END DO CALL RSORTI (e_r(o), ind, nn, 16, JSW) CALL RORDER (e_t(o), ind, nn) CALL IORDER (e_k(o), ind, nn) CALL IORDER (e_c(o), ind, nn) CALL IORDER (e_p1(o), ind, nn) CALL IORDER (e_p2(o), ind, nn) CALL RORDER (e_p3(o), ind, nn) CALL IORDER (e_v(o), ind, nn) CALL IORDER (e_g(o), ind, nn) j = 1 h = o ! track #, starting offset DO i = o, indon IF (i < indon .AND. e_r(i) .EQ. j) THEN CYCLE ELSE IF (i .EQ. indon) THEN L = i - h + 1 ELSE L = i - h END IF * segregate streams by contrapuntal analysis CALL PUNTAL (e_t(h), e_p1(h), e_k(h), L, V(h), msv, PUNB, & PUNNIV, PUNNOV, PUNIND, PUNTOF, PUNLST, fault) IF (fault .NE. 0) PRINT *, 'puntal: error#', fault * error check for PUNTAL DO m = h, h+L-1 IF (V(m) > 0 .AND. e_k(m) .NE. 1) THEN PRINT *, 'at h=', h, ' i=', i, ' j=', j, ' bad assignment', & ' V=', V(m), ' but e_k=', e_k(m) * reject the bad assignment, attempt to continue V(m) = 0 END IF END DO * renumber IF (fault .EQ. 0) THEN DO g = h, h+L-1 IF (V(g) > 0) V(g) = V(g) + nv END DO nv = nv + msv END IF j = e_r(i) ! next track h = i ! next offset position END DO CALL DTIME(tarray, result) ! PRINT *, 'made ', nv, ' voices. in CPU time: ', tarray(1) * If splitting voices, change tracks IF (opt_P) THEN DO i = 1, ind0 e_k(i) = e_k(i) + 2 ! unmark drums e_r(i) = nv + 3 ! drums after all voices END DO DO i = o, indon IF (e_k(i) .EQ. 1) THEN IF (V(i) .EQ. 0) THEN e_r(i) = nv + 2 ! put strays onto next-to last track ELSE e_r(i) = V(i) + 1 ! leave track 1 as a tempo map END IF END IF END DO END IF * early return? IF ( .NOT. (opt_G .OR. opt_K .OR. opt_L .OR. opt_Q & .OR. opt_S .OR. opt_T .OR. opt_V .OR. getcfg) ) RETURN *----------------------------------------------------------------------- * find the key(s) *----------------------------------------------------------------------- * sort by kind, because chordal() needs Note-Offs * to precede any simultaneous Note-Ons DO i = 1, nn ind(i) = i END DO CALL RSORTI (e_k(o), ind, nn, -7, JSW) CALL RORDER (e_t(o), ind, nn) CALL IORDER (e_c(o), ind, nn) CALL IORDER (e_p1(o), ind, nn) CALL IORDER (e_p2(o), ind, nn) CALL RORDER (e_p3(o), ind, nn) CALL IORDER (e_v(o), ind, nn) CALL IORDER (e_g(o), ind, nn) CALL IORDER (e_r(o), ind, nn) CALL IORDER (V(o), ind, nn) DO i = 1, nn ind(i) = i END DO CALL MSORTR (e_t(o), ind, nn, RSW, JSW) CALL IORDER (e_k(o), ind, nn) CALL IORDER (e_c(o), ind, nn) CALL IORDER (e_p1(o), ind, nn) CALL IORDER (e_p2(o), ind, nn) CALL RORDER (e_p3(o), ind, nn) CALL IORDER (e_v(o), ind, nn) CALL IORDER (e_g(o), ind, nn) CALL IORDER (e_r(o), ind, nn) CALL IORDER (V(o), ind, nn) * find the minimal partitions for key and chord CALL SEGMENT (e_t(o), e_p1(o), e_k(o), nn, pall, partit, & seg, cumseg, fault) IF (opt_K) THEN CALL KEYAL (partit, cumseg, pall, key_t, sharps, majmin, nk, & ind, cumw, uprofile, usecfg, fault) CALL DTIME(tarray, result) ! PRINT *, ' time finding key: ', tarray(1) END IF ! ~K ? *----------------------------------------------------------------------- * do the chordal analysis *----------------------------------------------------------------------- IF (opt_G .OR. opt_L) THEN ! evaluate probability job = 'E' ELSE IF (getcfg) THEN ! collect training data job = 'T' ELSE IF (opt_Q .OR. opt_S .OR. opt_T .OR. opt_V) THEN ! label chords job = 'L' ELSE GO TO 33 END IF CALL CHORDAL (partit, seg, cumseg, pall, & key_t, sharps, majmin, nk, job, c, ch_t, Q, R, & phar, ccarr, uprox, uqual, uroot, fault) IF (fault .NE. 0) PRINT *, 'chordal: error #', fault CALL DTIME(tarray, result) ! PRINT *, ' time doing harmony: ', tarray(1) !!! check chord output ! PRINT *, 'made ', c, ' chords: ' ! DO j = 1, c ! PRINT 11, j, partit(j), q(j), r(j) ! END DO ! 11 FORMAT (I5, ' time:', F9.3, 2I3) *----------------------------------------------------------------------- * find rhythmic saliences. *----------------------------------------------------------------------- * unmark drum events 33 DO i = 1, ind0 e_k(i) = e_k(i) + 2 END DO nn = indon ! Note-Ons and Note-Offs DO i = 1, nn ind(i) = i END DO CALL RSORTI (e_k, ind, nn, 7, JSW) ! sort by kind CALL RORDER (e_t, ind, nn) CALL IORDER (e_c, ind, nn) CALL IORDER (e_p1, ind, nn) CALL IORDER (e_p2, ind, nn) CALL RORDER (e_p3, ind, nn) CALL IORDER (e_v, ind, nn) CALL IORDER (e_g, ind, nn) CALL IORDER (e_r, ind, nn) CALL IORDER (V, ind, nn) CALL IBSLE (e_k, nn, 0, indoff) ! last Note-Off event no = indon - indoff ! Note-Ons DO i = 1, nn ind(i) = i END DO ! sort by time CALL MSORTR (e_t, ind, nn, RSW, JSW) CALL IORDER (e_k, ind, nn) CALL IORDER (e_c, ind, nn) CALL IORDER (e_p1, ind, nn) CALL IORDER (e_p2, ind, nn) CALL RORDER (e_p3, ind, nn) CALL IORDER (e_v, ind, nn) CALL IORDER (e_g, ind, nn) CALL IORDER (e_r, ind, nn) CALL IORDER (V, ind, nn) * initialize to zero DO i = 1, no S(i) = 0. END DO *----------------------------------------------------------------------- * melodic accent per stream *----------------------------------------------------------------------- DO j = 1, nv a = 0 DO i = 1, nn IF (V(i) .EQ. j) THEN a = a + 1 pitseq(a) = e_p1(i) END IF END DO CALL CONTOUR (pitseq, accent, a) a = 0 m = 0 DO i = 1, nn IF (e_k(i) .EQ. 1) m = m + 1 IF (V(i) .EQ. j) THEN IF (e_k(i) .NE. 1) STOP 'assigned a non-note-on event!' a = a + 1 S(m) = sal_mel * accent(a) ! PRINT *, 'Event ', i, ' has melodic accent: ', accent(a) * Fake velocity IF (opt_V) THEN ! PRINT *, 'multiplying by: ', accent(a) e_p2(i) = INT(e_p2(i) * (1. + FAKPAR * (accent(a) - 1.))) e_p2(i) = MIN(MAX(128, e_p2(i)), 16383) END IF END IF END DO END DO ! next stream CALL DTIME(tarray, result) ! PRINT *, ' time for mellacc: ', tarray(1) * early return? IF ( .NOT. (opt_G .OR. opt_L .OR. opt_Q & .OR. opt_S .OR. opt_T .OR. getcfg) ) RETURN *----------------------------------------------------------------------- * scale duration in the manner of Toivaianen & Eerola's Midi Toolbox: * S = c @ (1 - e^(t / tau)) * who cite: * R. Parncutt * "A Perceptual Model of Pulse Salience and Metrical Accent in Musical Rhythms" * Music Perception 11(4), 409-464 * also scale velocity, drum and bass *----------------------------------------------------------------------- m = 0 tau1 = 1. / tau DO i = 1, indon IF (e_k(i) .EQ. 1) THEN m = m + 1 S(m) = S(m) + sal_dur * (1. - SNAP(-e_p3(i) * tau1)) ! duration S(m) = S(m) + sal_vel * FLOAT(e_p2(i)) / 16384. ! salience of velocity IF (drum(e_c(i))) THEN S(m) = S(m) + sal_dru ! bonus for drums ELSE S(m) = S(m) + sal_bas * (127. - FLOAT(e_p1(i))) / 127. ! bonus for bass END IF T(m) = e_t(i) ! copy Note-On times END IF END DO *----------------------------------------------------------------------- * merge identical onset times and their saliences *----------------------------------------------------------------------- tprev = T(1) m = 1 DO i = 2, no tnext = T(i) IF (ABS(tnext-tprev) < pip) THEN S(m) = S(m) + S(i) ELSE m = m + 1 T(m) = tnext S(m) = S(i) tprev = tnext END IF END DO *----------------------------------------------------------------------- * add in harmonic salience *----------------------------------------------------------------------- a = 1 DO i = 1, m IF (a .LE. c) THEN IF (ABS(ch_t(a) - T(i)) < pip) THEN S(i) = S(i) + sal_har a = a + 1 ELSE IF (ch_t(a) < T(i)) THEN a = a + 1 END IF END IF END DO CALL DTIME(tarray, result) ! PRINT *, ' time fiddling with saliences: ', tarray(1) !* rescale to average salience of ETA ! TOT = 0. ! DO i = 1, M ! TOT = TOT + S(i) ! END DO ! FACTOR = ETA * FLOAT(M) / TOT ! DO i = 1, M ! S(i) = S(i) * FACTOR ! END DO *----------------------------------------------------------------------- * call the rhythmic strata routine *----------------------------------------------------------------------- IF (getcfg) ! add data to rhythm parameters & CALL ADRP (T, S, M, NSTEPS, STEP, RHYA, RHYP, RHYF, RSUM) nt = 0 full = opt_G .OR. opt_Q .OR. opt_L CALL STRATA (T, S, n_s, TL, m, NSTEPS, NODES, step, rpar, opt_S, & opt_T, usecfg, full, prhy, CX, CY, CA, CB, CC, TX, TA, nt, & avgtem, RHYA, RHYP, RHYF, RHYB, RHYC, RHYW, RHYX, RHYY, & RHYZ, fault) IF (fault .NE. 0) PRINT *, 'strata: error #', fault CALL DTIME(tarray, result) ! PRINT *, ' time for rhythm: ', tarray(1) *----------------------------------------------------------------------- * quantize to tatum grid *----------------------------------------------------------------------- IF (opt_Q) THEN CALL SEVAL (CX, CY, CA, CB, CC, NODES, e_t, e_u, e_w, e, fault) DO i = 1, e du = e_u(i) - ANINT(e_u(i)) ! phase difference dt = du / e_w(i) ! time difference e_t(i) = e_t(i) - dt ! adjust time IF (e_k(i) .EQ. 1) & e_p3(i) = ANINT(e_p3(i) * e_w(i)) / e_w(i) ! quantize duration END DO CALL duroff (e_t, e_k, e_c, e_p1, e_p2, e_p3, e_v, e_g, e_f, & e_r, ind, RSW, JSW, e, psi) END IF ! Q? *----------------------------------------------------------------------- * Calculate metrical time each event *----------------------------------------------------------------------- IF (opt_G .OR. opt_S) THEN CALL SCOMP (CX, CY(1,TL), CA(1,TL), CB(1,TL), CC(1,TL), NODES, $ e_t, e_u, e, fault) IF (fault .NE. 0) PRINT *, 'scomp returns #', fault !!!!!!!!!!!!! debugging: DO i = 1, e IF (e_u(i) .NE. e_u(i)) THEN PRINT *, 'analyz: NaN in metrical time! i: ', i PRINT *, 'nodes: ', NODES, ' e: ', e PRINT *, 'CX: ', CX PRINT *, 'CY: ', CY PRINT *, 'CA: ', CA PRINT *, 'CB: ', CB PRINT *, 'CC: ', CC PRINT *, 'e_t: ', e_t ! STOP END IF END DO !!!!!!!!!!!!!!!!!!!!!!!!!!!! END IF ! opt_G or opt_S ? *----------------------------------------------------------------------- * force a steady tempo *----------------------------------------------------------------------- IF (opt_S) THEN factor = 1. / avgtem j = 0 ! count tempo events DO i = 1, e IF (e_k(i) .EQ. 70) THEN IF (j .EQ. 0) THEN ! alter first tempo event e_t(i) = 0. e_c(i) = 0 e_p3(i) = avgtem e_r(i) = 1 ELSE e_k(i) = 99 ! erase other tempo events END IF j = j + 1 ELSE ! not tempo event e_t(i) = e_u(i) * factor END IF ! tempo event ? END DO ! next event END IF ! opt_S ? *----------------------------------------------------------------------- * store detected tempos *----------------------------------------------------------------------- IF (opt_T) THEN DO i = 1, nt ttmp(i) = TX(i) thz(i) = TA(i) IF (opt_L) PRINT *, 'Tempo change at time ', ttmp(i), ' to ', $ thz(i)*60, ' beats per minute' END DO END IF *----------------------------------------------------------------------- * analyze melody *----------------------------------------------------------------------- IF (opt_G .OR. opt_L .OR. getcfg) THEN ! optional phase pmel = 0. aff = 0. meltim = 0. afftim = 0. DO 66 j = 1, nv a = 0 DO i = 1, nn IF (V(i) .EQ. j) THEN a = a + 1 timseq(a) = e_t(i) pitseq(a) = e_p1(i) END IF END DO IF (a .EQ. 0) GO TO 66 IF (getcfg) & CALL adtp (timseq, pitseq, a, key_t, sharps, majmin, & nk, uprofile, ms, ms2) IF (opt_G .OR. opt_L) THEN DO i = 1, n_s ! phases of each event CALL SCOMP(CX, CY(1,i), CA(1,i), CB(1,i), CC(1,i), NODES, & timseq, beat(1,i), a, fault) END DO CALL melody (timseq, pitseq, a, key_t, sharps, majmin, nk, & beat, 2*n, pkarr, p, fault) IF (fault .NE. 0) PRINT *, ' melody: error#', fault pmel = pmel + p CALL DTIME(tarray, result) meltim = meltim + tarray(1) CALL affine (timseq, pitseq, a, key_t, sharps, majmin, nk, & beat(1,1), CEIL(beat(a,1)), aff0, fault) IF (fault .NE. 0) PRINT *, 'affine: error# ', fault ! PRINT *, 'stream ', j, ' self-affinity: ', aff0 aff = aff + aff0 CALL DTIME(tarray, result) afftim = afftim + tarray(1) END IF 66 CONTINUE ! next stream paff = -no * aff / nv ! fake ! PRINT *, ' time for melody: ', meltim, ' for affinity: ',afftim * fitness rating from harmonic, rhythmic, melodic, and fractal analyses p = whar*phar + wrhy*prhy + wmel*pmel + waff*paff ! PRINT *, 'results of analysis: harmony=', PHAR, ' rhythm=', ! & PRHY, ' melody=', PMEL, ' affinity=', PAFF END IF ! analyzing melody and affinity ? IF (.NOT. opt_L) RETURN ! remainder is for idle curiousity *----------------------------------------------------------------------- * specify fixed-width layout *----------------------------------------------------------------------- 10 FORMAT (1X, F9.3, $) ! time: 1234.567 20 FORMAT (1X, A9, $) ! phase: \\\\\\\\\ 30 FORMAT (1X, A88, $) ! piano roll punches: # + 40 FORMAT (1X, A8, $) ! chord: Bbbm7 50 FORMAT () ! end of record *----------------------------------------------------------------------- * print results of analysis *----------------------------------------------------------------------- DO I = 0, 127 ! ignore channel ! PSI(I,0) = 0 END DO I = 1 ! index events G = 1 ! index chord changes H = 1 ! index key changes L = CEIL(TEND / PIP) ! how many pips QNEW = -999 RNEW = -999 SHNEW = -999 MMNEW = -999 DO J = 0, L QOLD = QNEW ROLD = RNEW SHOLD = SHNEW MMOLD = MMNEW * real time TNEXT = J * PIP PRINT 10, TNEXT * measure phase CALL SCOMP (CX, CY(1,TL+1), CA(1,TL+1), CB(1,TL+1), CC(1,TL+1), & NODES, TNEXT, PHI, 1, fault) CALL MKPHAA (PHI, PHAA) PRINT 20, PHAA * tactus phase CALL SCOMP (CX, CY(1,TL), CA(1,TL), CB(1,TL), CC(1,TL), & NODES, TNEXT, PHI, 1, fault) CALL MKPHAA (PHI, PHAA) PRINT 20, PHAA * tatum phase CALL SCOMP (CX, CY, CA, CB, CC, NODES, TNEXT, PHI, 1, fault) CALL MKPHAA (PHI, PHAA) PRINT 20, PHAA * seek note on/off events 70 CONTINUE IF (I .LE. E) THEN IF (E_T(i) .LE. TNEXT) THEN IF (E_K(i) .EQ. 0) THEN ! note off PSI(e_p1(i),0) = 0 ELSE IF (E_K(i) .EQ. 1) THEN ! note on PSI(e_p1(i),0) = i END IF I = I + 1 GO TO 70 END IF END IF DO M = 1, 88 ! print voice number at beginning of note o = PSI(M+20,0) IF (o .EQ. 0) THEN SCROLL(M:M) = ' ' ELSE IF (SCROLL(M:M) .EQ. ' ') THEN WRITE(UNIT=SCROLL(M:M), FMT='(I1)') V(o) ELSE SCROLL(M:M) = PUNCT(E_P2(o) / 3277 + 1) END IF END DO PRINT 30, SCROLL * seek chord changes 80 CONTINUE IF (G .LE. C) THEN IF (CH_T(G) .LE. TNEXT) THEN QNEW = Q(G) RNEW = R(G) G = G + 1 GO TO 80 END IF END IF * seek key changes 90 CONTINUE IF (H .LE. NK) THEN IF (KEY_T(H) .LE. TNEXT) THEN SHNEW = SHARPS(H) MMNEW = MAJMIN(H) H = H + 1 GO TO 90 END IF END IF * Use tonal pitch class spelling of root, given a key signature IF (QOLD .NE. QNEW .OR. ROLD .NE. RNEW) THEN tpc = spell(RNEW, SHNEW) M = LEN_TRIM(tpc) PRINT 40, tpc(1:M) // quality_name(QNEW) // ' ' ELSE PRINT 40, ' ' END IF * print key IF (SHOLD .NE. SHNEW .OR. MMOLD .NE. MMNEW) THEN sig = keysig_name(SHNEW,MMNEW) M = LEN_TRIM(SIG) PRINT 40, SIG(1:M) // MMNAM(MMNEW) ELSE PRINT 40, ' ' END IF * terminate line PRINT 50 END DO ! next J PRINT *, 'harmonic probability: ', phar PRINT *, 'rhythmic probability: ', prhy PRINT *, 'melodic probability: ', pmel PRINT *, 'affinity probabililty: ', paff PRINT *, 'weighted score: ', p RETURN END ! of ANALYZ *----------------------------------------------------------------------- * make phase ASCII art *----------------------------------------------------------------------- SUBROUTINE MKPHAA (PHI, PHAA) IMPLICIT NONE REAL PHI CHARACTER*9 PHAA * locals INTEGER L REAL RP, TWOPI CHARACTER BACKSL PARAMETER (BACKSL = '\\') CHARACTER*9 SPRING, SUMMER, FALL, WINTER, EMPTY CHARACTER SPRARR(9) EQUIVALENCE (SPRING, SPRARR) SAVE TWOPI, SPRING, SUMMER, FALL, WINTER, EMPTY DATA TWOPI / 6.2831853 / DATA SPRARR / 9 * BACKSL / DATA SUMMER / '---------' / DATA FALL / '/////////' / DATA WINTER / '|||||||||' / DATA EMPTY / ' ' / * begin PHAA = EMPTY RP = PHI - AINT(PHI) ! Remainder phase L = NINT(9. * (COS(TWOPI * RP) + 1.) / 2.) IF (L .EQ. 0) RETURN IF (RP < 0.125) THEN PHAA = SUMMER(1:L) ELSE IF (RP < 0.375) THEN PHAA = FALL(1:L) ELSE IF (RP < 0.625) THEN PHAA = WINTER(1:L) ELSE IF (RP < 0.875) THEN PHAA = SPRING(1:L) ELSE PHAA = SUMMER(1:L) END IF RETURN END ! of MKPHAA *++++++++++++++++++++++ End of file analyz.f +++++++++++++++++++++++++++