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