************************************************************************
*  mixmidi - mix or manipulate symbolic musical data
*  by Andy Allinger, 2009-2017, released to the public domain
*  This program may be used by any person for any purpose.
************************************************************************
*
* For the most recent released version, visit:
* 13olive.net/software.html
* or write andy_a@users.sourceforge.net
*
************************************************************************
*                        COMMAND LINE OPTIONS
************************************************************************
*
*  -A    option[1]     align times to click track
*  -B    option[2]     all files begin at time 0
*  -C    option[3]     separate by channel
*  -D    option[4]     specify drum channels
*  -E    option[5]     expectation maximization algorithm
*  -F    option[6]     scale times so files finish together
*  -G    option[7]     run genetic algorithm
*  -H    option[8]     use hyperplane partition
*  -I    option[9]     mix, yield the intersection of input
*  -J    option[10]    jitter input
*  -K    option[11]    detect key signatures
*  -L    option[12]    long form output
*  -M    option[13]    detect meter
*  -N    option[14]    permit making overlapping notes
*  -O    option[15]    use mean values instead of median
*  -P    option[16]    separate input by counterpoint analysis
*  -Q    option[17]    quantize output
*  -R    option[18]    mix, removing some data from result
*  -S    option[19]    force a steady tempo
*  -T    option[20]    detect tempo
*  -U    option[21]    union - combine all events into 1 file
*  -V    option[22]    enhance velocity
*  -W    option[23]    disunion - separate tracks to files
*  -X    option[24]    mix, yield mutual exclusion of input
*  -Y    option[25]    mix, with a user-specified yield fraction
*  -Z    option[26]    combine tracks into a type-0 file
*  -$    option[27]    extract configuration data from files
************************************************************************
      PROGRAM mm
       IMPLICIT NONE
       
*           named constants       
       INTEGER minstp, mnf, n_kind, num_q, n_sex
       REAL step
       LOGICAL dump, linux, rsrch
       PARAMETER ( dump = .FALSE.,    ! sets debug data dump
     $             linux = .FALSE.,   ! print copyright for METIS and graclus
     $             mnf = 144,         ! maximum number of input files
     $             minstp = 7,        ! minimum timepoints (match rhythm.f)
     $             n_kind = 90,       ! # of event kinds (match midifile.f)
     $             num_q = 15,        ! qualities (match harmony.f, analyz.f)
     $             n_sex = 3,         ! must match GENE
     $             rsrch = .FALSE.,   ! use melisma2 instead of ANALYZ
     $             step = 0.1)        ! metrical grid spacing, [s]
       INTEGER Luqual
       PARAMETER (Luqual = 2 * num_q)  ! length of uqual array 

       INTEGER           
     $  a, 
     $  argcount,                 ! # command line arguments
     $  BITSZ,                    ! alternative to BIT_SIZE
     $  BKIN(12),                 ! kinds that are blobs
     $  CEIL,                     ! alternative to CEILING function
     $  clktrk,                   ! specify a click track
     $  ctab(0:15),               ! which track to put each channel onto
     $  eact,                     ! actual number of events
     $  epad,                     ! eact increased by detected events
     $  etot,                     ! total input number of events   
     $  fault,                    ! error return code
     $  i, j, k, L, m,            ! counters
     $  iou                       ! file I/O Unit
       INTEGER
     $  keylim,                   ! bound for key-change arrays
     $  kul, 
     $  Ltot,                     ! total length of files
     $  mnr,                      ! most tracks any file
     $  mnn,                      ! most NoteOn's any file
     $  nb,                       ! number of blob-type events in input
     $  n_cfg,                    ! number of .CFG files on command line
     $  NDIG,                     ! number of digits to process
     $  n_gen,                    ! number of generations
     $  no, nsteps, npts,         ! # Note-Ons, # timepoints, # spline points
     $  nk, nt,                   ! # of detected key, tempo changes
     $  n_file,                   ! # input files
     $  of,                       ! ID for the output file
     $  olim,                     ! lengths of events lists in genetic alg.
     $  psi(0:127,0:15),          ! pointer to sound inception
     $  sarray(13),               ! array for STAT()
     $  tmplim                    ! bound for tempo-change arrays
     
       REAL 
     $      avgtem,        ! average tempo
     $      cfgval,        ! number read from config file
     $      fit_a,         ! fitness of result file
     $      p,             ! log probability of a file
     $      tf,            ! overall end time
     $      told, tnew,    ! click times
     $      yield          ! fraction of input to yield in output

       CHARACTER 
     $           opt,               ! an option letter
     $           thisly             ! 'A', 'D', 'G', 'Y', or '~' (neither)
     
       CHARACTER*4 ext              ! filename extension
       CHARACTER*5 trdig            ! track # as a string
       CHARACTER*10 digit           ! 1-9, 0
       CHARACTER*17 CREDIT,         ! to insert into BUF.  keep .LE. 22 chars!
     $              cfglab(96),     ! configuration file label strings
     $              cfgpar          ! keep .GE. 17 chars!
       CHARACTER*27 optlet          ! A-Z, $
       
       CHARACTER*80 
     $              version         ! program id string
     
       CHARACTER*256 
     $               argval,         ! command line argument
     $               c_name,         ! config file name
     $               f_name(mnf),    ! input file names
     $               line,           ! input from data file
     $               o_name          ! output file
       
       LOGICAL
     $        anon,                   ! analyze only (no output midi)
     $        cuse(0:15),             ! channel usage
     $        drum(0:15),             ! is a drum channel?
     $        fe,                     ! file exists
     $        gethelp,                ! option -?
     $        option(27),             ! which command line options chosen
     $        rid(mnf),               ! eliminate events from this file
     $        usecfg,                 ! user supplies configuration data
     $        usehrv                  ! use hi-res velocity

*             configuration data
       REAL pkarr(0:127, 0:127, 0:11, 0:1)         ! proximity-key array
       REAL ccarr(num_q, 0:11, 0:11, 0:1)          ! chord change probability
       REAL uprofile(0:11, 0:1), uvar              ! melodic pitch profile
       REAL urpar(8)                               ! rhythm analysis parameters
       REAL uprox(0:6), uqual(num_q, 0:1), uroot(0:11, 0:1) ! harmony parm's
       DOUBLE PRECISION ms, ms2                  ! sums for configuring melody
       DOUBLE PRECISION rsum(9)                  ! sums for configuring rhythm
       
       REAL tarray(2), result                       ! arguments to DTIME
       
*              external functions
       INTEGER KTRIM, LTRIM,            ! lengths of a trimmed string
     $         IOUNIT                   ! find valid I/O Unit #
       
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
*                 allocatable arrays
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
       INTEGER*1, DIMENSION (:), ALLOCATABLE :: buf !  buffer, bytes

       INTEGER, DIMENSION (:), ALLOCATABLE :: 
     $      L_file,                                     ! length of file, bytes
     $  a_s, a_k, a_c, a_p1, a_p2, a_v, a_g, a_f, a_r,  ! clustered events
     $  e_s, e_k, e_c, e_p1, e_p2, e_v, e_g, e_f, e_r,  ! input events
     $  aind, 
     $  ind,                    ! permutation vector
     $  JWE, JWA,               ! sorting workspace
     $  majmin,                 ! major or minor keys [keylim]
     $  n_trk,                                          ! tracks each file
     $  sharps                  ! # sharps in key sig [keylim]
     
       INTEGER, DIMENSION (:,:), ALLOCATABLE ::
     $  kuse                   ! events each kind each track [n_kind,mnr]
     
       INTEGER, DIMENSION (:,:,:), ALLOCATABLE ::
     $  usgkrf                        ! events each kind, each track, each file

       REAL, DIMENSION (:), ALLOCATABLE ::
     $  a_t, a_p3, a_u,                                  ! clustered events
     $  e_t, e_p3, e_u,                                  ! input events
     $  RWE, RWA,                ! sorting workspace
     $  fit_e,                   ! fitness of input [n_file]
     $  key_t,                   ! times of key changes [keylim]
     $  tend,                    ! end time of each file [n_file]
     $  thz,                     ! detected tempo in Hertz
     $  ttmp                     ! time of detected tempo

       LOGICAL, DIMENSION (:), ALLOCATABLE :: bk, bs, bt ! per file
     
************************************************************************
*             initialize
************************************************************************
       DATA BKIN / 58, 59, 61, 62, 63, 64, 65, 66, 67, 68, 69, 75 /
       DATA cuse / 16 * .FALSE. /
       DATA drum / 16 * .FALSE. /
       DATA clktrk, n_gen, yield / 0, 0, 0. /
       DATA option, gethelp / 27 * .FALSE., .FALSE. /
       DATA usecfg / .FALSE. /
       DATA rid / mnf * .FALSE. /
       PARAMETER (optlet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ$')
       PARAMETER (digit = '1234567890')
       DATA uprofile, uvar / 24 * 0., 0. /         ! melodic pitch profile
       DATA ms, ms2 / 0.D0, 0.D0 /
       DATA rsum / 9 * 0.D0 /
       DATA uprox, uqual, uroot / 7 * 0., Luqual * 0., 24 * 0. /  ! harmony
       DATA cfglab(1:25) /    'PIT_PROF_I_MAJ', 'PIT_PROF_I#_MAJ',
     $  'PIT_PROF_II_MAJ', 'PIT_PROF_II#_MAJ', 'PIT_PROF_III_MAJ',
     $  'PIT_PROF_IV_MAJ', 'PIT_PROF_IV#_MAJ', 'PIT_PROF_V_MAJ',
     $  'PIT_PROF_V#_MAJ', 'PIT_PROF_VI_MAJ', 'PIT_PROF_VI#_MAJ',
     $  'PIT_PROF_VII_MAJ', 'PIT_PROF_I_MIN', 'PIT_PROF_I#_MIN',
     $  'PIT_PROF_II_MIN', 'PIT_PROF_III_MIN', 'PIT_PROF_III#_MIN',
     $  'PIT_PROF_IV_MIN', 'PIT_PROF_IV#_MIN', 'PIT_PROF_V_MIN',
     $  'PIT_PROF_VI_MIN', 'PIT_PROF_VI#_MIN', 'PIT_PROF_VII_MIN',
     $  'PIT_PROF_VII#_MIN', 'PIT_VAR' /
       DATA cfglab (26:40) / 'T_TATUM', 'DEV_TATUM', 
     $  'T_TACTUS', 'DEV_TACTUS', 'T_STROPHE', 'DEV_STROPHE', 
     $  'DEV_FREQ', 'DEV_PHASE', 'PROX_0', 'PROX_1', 'PROX_2', 'PROX_3',
     $  'PROX_4', 'PROX_5', 'PROX_6' /
       DATA cfglab(41:70) / 'QUAL_MAJ_MAJ', 'QUAL_M_MAJ','QUAL_7_MAJ',
     $  'QUAL_MAJ7_MAJ', 'QUAL_M7_MAJ', 'QUAL_6_MAJ', 'QUAL_M6_MAJ', 
     $  'QUAL_DIM_MAJ', 'QUAL_AUG_MAJ', 'QUAL_DIM7_MAJ', 'QUAL_7-5_MAJ',
     $  'QUAL_7SUS4_MAJ', 'QUAL_9_MAJ', 'QUAL_11_MAJ', 'QUAL_13_MAJ', 
     $  'QUAL_MAJ_MIN', 'QUAL_M_MIN', 'QUAL_7_MIN', 'QUAL_MAJ7_MIN', 
     $  'QUAL_M7_MIN', 'QUAL_6_MIN', 'QUAL_M6_MIN', 'QUAL_DIM_MIN', 
     $  'QUAL_AUG_MIN', 'QUAL_DIM7_MIN', 'QUAL_7-5_MIN', 
     $  'QUAL_7SUS4_MIN', 'QUAL_9_MIN', 'QUAL_11_MIN', 'QUAL_13_MIN' /
       DATA cfglab(71:94) /  'ROOT_I_MAJ', 'ROOT_I#_MAJ',
     $  'ROOT_II_MAJ', 'ROOT_II#_MAJ', 'ROOT_III_MAJ', 'ROOT_IV_MAJ',
     $  'ROOT_IV#_MAJ', 'ROOT_V_MAJ', 'ROOT_V#_MAJ', 'ROOT_VI_MAJ',
     $  'ROOT_VI#_MAJ', 'ROOT_VII_MAJ', 'ROOT_I_MIN', 'ROOT_I#_MIN',
     $  'ROOT_II_MIN', 'ROOT_III_MIN', 'ROOT_III#_MIN', 'ROOT_IV_MIN',
     $  'ROOT_IV#_MIN', 'ROOT_V_MIN', 'ROOT_VI_MIN', 'ROOT_VI#_MIN',
     $  'ROOT_VII_MIN', 'ROOT_VII#_MIN' /
       
*                   version name here
       PARAMETER (version = 'MIXMIDI version 5 Nov 2017')
       PARAMETER (CREDIT = 'Made with MIXMIDI')
        
***** ******************************************************************
*           begin
***** ******************************************************************
       CALL SRAND(TIME())
       
*                interpret command line
       argcount = IARGC()
       n_file = 0
       n_cfg = 0
       
       DO i = 1, argcount
         CALL GETARG(i, argval)
         L = LTRIM(argval)
         thisly = '~'
         m = 0 ; NDIG = 0
         
************************************************************************
*          lawyers
************************************************************************   
         IF (argval(1:L) .EQ. '--license') GO TO 70
         
************************************************************************
*               interpret options         
************************************************************************
         IF (argval(1:1) .EQ. '-') THEN       ! read option
           DO j = 2, L
             opt = argval(j:j)
             
*                  expect number             
             IF (thisly .EQ. 'A' .OR. thisly .EQ. 'D' 
     $           .OR. thisly .EQ. 'G' .OR. thisly .EQ. 'Y') THEN
               k = INDEX(digit, opt)
               IF (k .EQ. 0) STOP 'mm: expected number'
               IF (k .EQ. 10) k = 0
               IF (thisly .EQ. 'A') THEN
                 clktrk = clktrk * 10 + k
               ELSE IF (thisly .EQ. 'D') THEN
                 m = m * 10 + k
               ELSE IF (thisly .EQ. 'G') THEN
                 n_gen = n_gen * 10 + k
               ELSE IF (thisly .EQ. 'Y') THEN
                 yield = yield * 10. + FLOAT(k)
                 NDIG = NDIG + 1
               END IF
             
             ELSE                    ! expect letter
               IF (opt .EQ. '?') THEN
                 gethelp = .TRUE.
                 GO TO 80
               ELSE
                 CALL UCASE (opt)
                 k = INDEX(optlet, opt)
                 IF (k .EQ. 0) STOP 'mm: expected letter'
                  option(k) = .TRUE.
                END IF

*                switch on option flags
               IF (opt .EQ. 'A') THEN
                 thisly = 'A'
               ELSE IF (opt .EQ. 'D') THEN
                 thisly = 'D'
               ELSE IF (opt .EQ. 'G') THEN
                 thisly = 'G'
               ELSE IF (opt .EQ. 'R') THEN
                 rid(n_file+1) = .TRUE.
                 thisly = '~'
               ELSE IF (opt .EQ. 'Y') THEN
                 thisly = 'Y'
               ELSE
                 thisly = '~'       ! nyet, comrade
               END IF
             END IF  ! number or letter ?
           END DO  ! next j

           IF (thisly .EQ. 'A') THEN
             IF (clktrk .GE. 1 .AND. clktrk .LE. 65535) THEN
               CONTINUE
             ELSE
               PRINT *, 'mm: bad track number'
               GO TO 80  !  bail
             END IF
           ELSE IF (thisly .EQ. 'D') THEN
             IF (m .GE. 1 .AND. m .LE. 16) THEN
               drum(m-1) = .TRUE.
             ELSE IF (m .EQ. 0) THEN
               CONTINUE       ! no drum channel
             ELSE
               PRINT *, 'mm: bad channel number'
               GO TO 80 ! bail
             END IF
           ELSE IF (thisly .EQ. 'Y') THEN
             yield = yield / 10. **NDIG
           END IF
           
************************************************************************
*            read a filename
************************************************************************
         ELSE 
           IF (L < 5) THEN
             PRINT *, 'mm:  file name too short'
             GO TO 80
           END IF
           ext = argval(L-3:L)
           CALL UCASE (ext)
           IF (ext .EQ. '.MID' .OR. ext .EQ. '.KAR') THEN         
             n_file = n_file + 1
             IF (n_file > mnf) THEN
               PRINT *, 'mm: too many files.  Limit is ', MNF, ' Sorry.'
               STOP
             END IF
             f_name(n_file) = argval(1:L)
           ELSE IF (ext .EQ. '.CFG') THEN
             n_cfg = n_cfg + 1
             c_name = argval(1:L)
           ELSE
             PRINT *, 'mm:  unrecognized file extension'
             GO TO 80  ! bail out
           END IF
         END IF
       END DO ! next command-line argument
       
************************************************************************
*             enough files?     
************************************************************************
       IF (n_file < 1) GO TO 80                        ! bail out
       anon = (n_file .EQ. 1 .AND. option(12))
              
*             the last file is for output
       IF (.NOT. (anon .OR. option(23) .OR. option(27)) ) THEN
         o_name = f_name(n_file)
         n_file = n_file - 1
         INQUIRE (FILE=o_name, EXIST=fe, ERR=90)     ! output file
         IF (fe) STOP 'no output file specfied'
       END IF
       
*            check number of config files, compatibility with getcfg option
       IF (n_cfg > 1) THEN
         PRINT *, 'mm:  too many config files'
         GO TO 80
       END IF
       IF (n_cfg .EQ. 1 .AND. .NOT. option(27)) usecfg = .TRUE.
           
*            check that 'R' option is not placed before output filename
       IF (rid(n_file+1)) THEN
         PRINT *, 'mm:  too many -Rs'
         GO TO 80
       END IF
       
*           not all files to rid
       j = 0
       DO k = 1, n_file
         IF (rid(k)) j = j + 1
       END DO
       IF (j .EQ. n_file) THEN
         PRINT *, 'mm:  cannot remove all input'
         GO TO 80
       END IF
       
*            set default drum channel 10 = 9 in zero-offset
       IF (.NOT. option(4)) drum(9) = .TRUE.       
         
************************************************************************
*           check options for compatibility 
************************************************************************
*                     only 1 mode of operation 
       j = 0          ! # modes of operation
       IF (option(3)) j = j + 1                   ! channels
       IF (option(7)) j = j + 1                   ! evolve
       IF (option(9)) j = j + 1                   ! intersect
       IF (option(16)) j = j + 1                  ! c'point
       IF (option(18)) j = j + 1                  ! rid
       IF (option(21)) j = j + 1                  ! union
       IF (option(23)) j = j + 1                  ! disunion
       IF (option(24)) j = j + 1                  ! exclusion
       IF (option(26)) j = j + 1                  ! zero
       IF (option(27)) j = j + 1                  ! configure
       IF (j > 1) THEN
         PRINT *, 'mm:  incompatible options'
         GO TO 80  ! bail out
       END IF
       
*              option N conflicts with anything that calls ANALYZ
       IF (option(14) .AND.
     $     (option(7) .OR. option(11) .OR. option(12) .OR. option(13)
     $      .OR. option(16) .OR. option(17) .OR. option(19)
     $       .OR. option(20) .OR. option(22) .OR. option(27))) THEN
         PRINT *, 
     $ 'mm:  option -N conflicts with -G -K -L -M -P -Q -S -T -V or -$'
         GO TO 80
       END IF
       
*              option N conflicts with mixing
       IF (option(14) .AND. (n_file > 1 .AND. .NOT. option(21))) THEN
         PRINT *, 'mm:  option -N conflicts with mix operation'
         GO TO 80
       END IF
       
*              options A, S and T conflict
       j = 0
       IF (option(1)) j = j + 1
       IF (option(19)) j = j + 1
       IF (option(20)) j = j + 1
       IF (j > 1) THEN
         PRINT *, 'mm:  options -A, -S, or -T conflict'
         GO TO 80
       END IF
       
*               check files for existence
       IF (usecfg) THEN
         INQUIRE (FILE=c_name, EXIST=fe, ERR=90)     ! config file
         IF (.NOT. fe) THEN
           L = LTRIM(c_name)
           PRINT *, 'mm: ', c_name(1:L), ' not found'
           GO TO 80
         END IF
       END IF 

       IF (option(27)) THEN                        ! never overwrite conf
         INQUIRE (FILE=c_name, EXIST=fe, ERR=90)
         IF (fe) THEN
           L = LTRIM(c_name)
           PRINT *, 'mm: ', c_name(1:L), ' already exists'
           GO TO 80
         END IF
       END IF
       
       DO k = 1, n_file
         INQUIRE (FILE=f_name(k), EXIST=fe, ERR=90)   ! input files
         IF (.NOT. fe) THEN
           L = LTRIM(f_name(k))
           PRINT *, 'mm: ', f_name(k)(1:L), ' not found'
           GO TO 80
         END IF
       END DO
       
*              1 file limit on some operations
       IF ( (option(1)                              ! opt_A ?
     $  .OR. option(3)                              ! opt_C ? 
     $  .OR. option(11)                             ! opt_K ?
     $  .OR. option(16)                             ! opt_P ?
     $  .OR. option(17)                             ! opt_Q ?
     $  .OR. option(19)                             ! opt_S ?
     $  .OR. option(20)                             ! opt_T ?
     $  .OR. option(22)                             ! opt_V ?
     $  .OR. option(23)                             ! opt_W ?
     $  .OR. option(26) )                           ! opt_Z ?
     $                   .AND. n_file .NE. 1) THEN
         PRINT *, 'this operation available only for single files'
         GO TO 80
       END IF
       
*               single file futile for some operations
       IF (( option(2)                             ! opt_B ?
     $  .OR. option(5)                             ! opt_E ?
     $  .OR. option(6)                             ! opt_F ?
     $  .OR. option(7)                             ! opt_G ?
     $  .OR. option(9)                             ! opt_I ?
     $  .OR. option(13)                            ! opt_M ?
     $  .OR. option(21)                            ! opt_U ?
     $  .OR. option(24)                            ! opt_X ?
     $  .OR. option(25) )                          ! opt_Y ?
     $                   .AND. n_file .EQ. 1) THEN
         PRINT *, 'option -B -E -F -G -I -M -U -X or -Y',
     $               ' not meaningful for single file'
         GO TO 80
       END IF       
       
*             add file lengths
*        this section of code possibly could be replaced with a 
*          loop of READ statements on systems which do not support STAT()
       ALLOCATE (L_file(n_file), STAT=fault)
       IF (fault .NE. 0) STOP 'mm: trouble allocating L_file!'
       Ltot = 0
       DO k = 1, n_file
         CALL STAT (f_name(k), sarray, fault)
         IF (fault .NE. 0) THEN 
           PRINT *, 'trouble reading file length!' 
           STOP
         END IF
         L_file(k) = sarray(8)    ! the only element of this array that matters
         Ltot = Ltot + L_file(k)
       END DO
       
*                splash credits
  10   FORMAT (A65)
       PRINT 10, version
       
!       PRINT *, 'options: ', OPTION, '  yield is ', yield
!        PRINT *, 'clktrk is: ', clktrk

*00000000000000000000000000000000000000000000000000000000000000000000000
*              allocate a buffer and read in the files
*00000000000000000000000000000000000000000000000000000000000000000000000
       ALLOCATE (buf(Ltot), n_trk(n_file),
     $  bt(n_file), bs(n_file), bk(n_file), STAT=fault)
       IF (fault .NE. 0) THEN
         PRINT *, 'mm: trouble allocating buffer'
         STOP
       END IF

*               count the events
       CALL CMIDI (buf, f_name, L_file, Ltot, n_file,
     $  mnn, mnr, nb, n_trk, bt, bs, bk, etot, fault)
!       PRINT *, 'CMIDI counted ', mnn, ' notes, ', mnr, ' tracks, ',
!     $  nb, ' blobs, ', etot, ' total events!' 
!       PRINT *, 'bt is: ', bt, ' bs is: ', bs, ' bk is: ', bk

       IF (fault .NE. 0) THEN
         PRINT *, 'CMIDI: error # ', fault
         STOP 'mm: couldnt process input file(s).  Sorry.'
       END IF
       
       DO k = 1, n_file
         IF (BT(k)) etot = etot + 1
         IF (BS(k)) etot = etot + 1
         IF (BK(k)) etot = etot + 1
       END DO
       etot = etot + 1          ! for credits
       
!!       PRINT *, 'etot has been changed to ', etot
              
*11111111111111111111111111111111111111111111111111111111111111111111111      
*              allocate event arrays
*11111111111111111111111111111111111111111111111111111111111111111111111      
       ALLOCATE (kuse(n_kind,mnr), 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), RWE(3*etot), JWE(3*etot), 
     $  fit_e(n_file), tend(n_file), STAT=fault)
       IF (fault .NE. 0) PRINT *, 'mm: trouble allocating arrays!'
            
*11111111111111111111111111111111111111111111111111111111111111111111111
*               interpret MIDI files
*11111111111111111111111111111111111111111111111111111111111111111111111
       CALL RMIDI (buf, f_name, L_file, Ltot, n_file, 
     $  option(2), option(6), option(14), 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, 
     $  JWE, tf, tend, eact, usehrv, psi, fault)
       IF (fault .NE. 0) PRINT *, 'RMIDI: error #', fault

!!!          DEBUG DUMP
       IF (dump) THEN
         PRINT *, 'read ', n_file, ' file(s) with', eact, ' events'
         PRINT *, 'time, kind, track, file, channel, par1, par2, par3 '
         DO i = 1, eact
           PRINT 11, e_t(i), e_k(i), e_r(i), e_f(i), e_c(i), e_p1(i), 
     $      e_p2(i), e_p3(i), e_v(i), e_g(i)
         END DO
       END IF       

!!          check that no subsumed events are slipping in
       DO i = 1, eact
         k = e_k(i)
         IF (k .EQ. 8) PRINT *, 'mm:  data entry event returned!'
         IF (k .EQ. 39) PRINT *, 'mm:  portamento event returned!'
         IF (k .EQ. 40) PRINT *, 'mm:  hi-res velocity event returned!'
         IF (k .EQ. 46) PRINT *, 'mm:  data button event returned!'
         IF (k .EQ. 48) PRINT *, 'mm:  registered parameter returned!'
       END DO
!!

!!!!!!!!!!!  check final times
!       PRINT *, 'tf is ', tf
!       PRINT *, 'tend is: ', tend

*-----------------------------------------------------------------------
*                allocate add'l space for detected events
*-----------------------------------------------------------------------
       tmplim = CEIL(tf / step)
       keylim = MAX(kuse(73,1), 2*mnn)      ! safe limit for key changes
       ALLOCATE (ttmp(tmplim), thz(tmplim), 
     $  key_t(keylim), sharps(keylim), majmin(keylim), STAT=fault)
       IF (fault .NE. 0) PRINT *, 'mm: trouble allocating extra arrays!'

*-----------------------------------------------------------------------
*          load configuration data
*-----------------------------------------------------------------------
       CALL DTIME(tarray, result)
       IF (usecfg) THEN
         iou = IOUNIT()
         OPEN (UNIT=iou, FILE=c_name, STATUS='OLD', 
     $    FORM='FORMATTED', ACCESS='SEQUENTIAL', IOSTAT=fault)
         IF (fault .NE. 0) STOP 'mm: trouble opening config file!'
         REWIND (UNIT=iou, ERR=90)

         DO 20 m = 1, 999
           READ (UNIT=iou, FMT='(A)', END=25, ERR=90) line
           k = KTRIM(line)
           L = LTRIM(line)
           i = INDEX(line, '*')                            ! ignore comments
           IF (i > 0) L = MIN(L, i-1)
           i = INDEX(line, '!')
           IF (i > 0) L = MIN(L, i-1)
           i = INDEX(line, '%')
           IF (i > 0) L = MIN(L, i-1)
           IF (k .GE. L) GO TO 20                  ! ignore blank lines
 
*                separate parameter name from parameter value
           j = INDEX(line(k:L), ' ') 
           IF (j .EQ. 0) THEN
             PRINT *, 'mm:  trouble reading configuration file ', c_name
             PRINT *, 'line ', m, ' could not be interpreted'
             PRINT *, 'line: ', line, ' K: ', K, ' L: ', L
             STOP
           END IF
           j = j + k - 1
       
           cfgpar = line(k:j-1)
           CALL UCASE (cfgpar)
       
           READ (UNIT=line(j+1:L), FMT=*, IOSTAT=fault) cfgval
           IF (fault .NE. 0) THEN
             PRINT *, 'mm:  trouble with numeric internal i/o'
             PRINT *, 'couldnt convert ', line(j+1:L)
             STOP
           END IF

************************************************************************
*             compare input name to list of recognized names
************************************************************************
           i = 0                ! count through labels
           DO k = 0, 1
             DO j = 0, 11
               i = i + 1
               IF (cfglab(i) .EQ. cfgpar) THEN
                 uprofile(j,k) = cfgval
                 GO TO 20
               END IF
             END DO
           END DO
           i = i + 1
           IF (cfglab(i) .EQ. cfgpar) THEN
             uvar = cfgval
             GO TO 20
           END IF
           DO j = 1, 8
             i = i + 1
             IF (cfglab(i) .EQ. cfgpar) THEN
               urpar(j) = cfgval
               GO TO 20
             END IF
           END DO
           DO j = 0, 6
             i = i + 1
             IF (cfglab(i) .EQ. cfgpar) THEN
               uprox(j) = cfgval
               GO TO 20
             END IF
           END DO
           DO k = 0, 1
             DO j = 1, num_q
               i = i + 1
               IF (cfglab(i) .EQ. cfgpar) THEN
                 uqual(j,k) = cfgval
                 GO TO 20
               END IF
             END DO
           END DO
           DO k = 0, 1
             DO j = 0, 11
               i = i + 1
               IF (cfglab(i) .EQ. cfgpar) THEN
                 uroot(j,k) = cfgval
                 GO TO 20
               END IF
             END DO
           END DO
  20     CONTINUE  ! next line of config file
  25     CLOSE (UNIT=iou, ERR=90)
           
         CALL DTIME(tarray, result)
!!         PRINT *, 'time reading config data: ', tarray(1)
       END IF  ! use config?

*-----------------------------------------------------------------------
*                initialize the Proximity-Key array
*-----------------------------------------------------------------------
       IF (option(7) .OR. option(12)) THEN       ! usually not req'd
         CALL MKCCARR (uprox, uqual, uroot, usecfg, ccarr)  ! set harmony data
         CALL MKPKARR (uprofile, uvar, usecfg, pkarr)  ! set melody data
         CALL DTIME(tarray, result)
!!!         PRINT *, ' time initializing ccarr, pkarr: ', tarray(1)
       END IF
       
*              set output file ID
       of = n_file + 1 
       
*-----------------------------------------------------------------------
*            Add random noise to input files
*-----------------------------------------------------------------------
       IF (option(10)) CALL JITTER (e_t, e_k, e_p1, e_p2, e_p3, eact)

*11111111111111111111111111111111111111111111111111111111111111111111111      
*             switch on operation to perform        
*11111111111111111111111111111111111111111111111111111111111111111111111      

*-----------------------------------------------------------------------
*            map channels to tracks
*-----------------------------------------------------------------------
       IF (option(3)) THEN              ! opt_C ?
         DO i = 1, eact              ! mark which channels are used
           IF (e_k(i) .GE. 58 .AND. e_k(i) .LE. 75) THEN  ! de-obfuscate
             k = MOD(e_c(i) + 1, 16) + 1
           ELSE
             k = e_c(i)
           END IF
           cuse(k) = .TRUE.
!!!!!!!!!!!!!!!!!! devbg           
!           IF (e_C(i) .GE. 10) 
!     $ PRINT *, 'event ', i, ' has channel ', e_c(i)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         END DO
!         PRINT *, 'cuse is: ', CUSE

         j = 1                            ! begin with track TWO
         DO i = 0, 15
           IF (cuse(i)) THEN
             j = j + 1
             ctab(i) = j
           ELSE
             ctab(i) = 1         ! in case of error, put onto first track
           END IF 
         END DO
!         PRINT *, 'using ctab: ', CTAB
       
         DO i = 1, eact              !  change tracks
           IF (e_k(i) .GE. 70 .AND. e_k(i) .LE. 73) THEN   
             e_r(i) = 1                       ! schedule events on track 1
           ELSE 
             IF (e_k(i) .GE. 58 .AND. e_k(i) .LE. 75) THEN
               k = MOD(e_c(i) + 1, 16) + 1
             ELSE 
               k = e_c(i)
             END IF
             e_r(i) = ctab(k)
           END IF
         END DO 
         mnr = j
         GO TO 50

*-----------------------------------------------------------------------
*             merge separate files into multi-track file
*-----------------------------------------------------------------------
       ELSE IF (option(21)) THEN           ! opt_U ?
         j = 0 ; k = 1             ! cumulative tracks, file #
         DO i = 1, eact             
           IF (e_f(i) .NE. k) THEN
             j = j + n_trk(k)
             k = e_f(i)
           END IF
           e_r(i) = e_r(i) + j

*           Null out schedule events not on first track, first file
           IF (e_k(i) .GE. 70 .AND. e_k(i) .LE. 73 
     $          .AND. e_r(i) .NE. 1) e_k(i) = 99
         END DO  ! next i
         mnr = j + n_trk(k)
         GO TO 50                      ! and write out

*-----------------------------------------------------------------------
*           split tracks to files
*-----------------------------------------------------------------------
       ELSE IF (option(23)) THEN               ! opt_W ?

*                sort by track
         IF (mnr > 0) THEN          ! find significant bits
           j = BITSZ()
           DO WHILE (.NOT. BTEST(mnr, j-1))
             j = j - 1
           END DO
         ELSE
           STOP 'mm: no tracks in input file!'
         END IF
         
         DO i = 1, eact ; ind(i) = i ; END DO
         CALL RSORTI (e_r, ind, eact, j, JWE)
         CALL RORDER (e_t, ind, eact)
         CALL IORDER (e_k, ind, eact)
         CALL IORDER (e_c, ind, eact)
         CALL IORDER (e_p1, ind, eact)
         CALL IORDER (e_p2, ind, eact)
         CALL RORDER (e_p3, ind, eact)
         CALL IORDER (e_v, ind, eact)
         CALL IORDER (e_g, ind, eact)
         CALL IORDER (e_f, ind, eact)
         
         i = 1   
         DO j = 1, mnr
           WRITE (UNIT=trdig, FMT='(I5.5)') j      ! make filename
           o_name = 'trk' // trdig // '.mid'
         
           k = i                           ! index of first event this track
           CALL IBSLE (e_r, eact, j, i)    ! index last event this track
           DO L = k, i           ! relabel events as track 1 (req'd for WMIDI) 
             e_r(L) = 1
           END DO 
           i = i + 1          ! index of first event next track
           L = i - k          ! length
           
                 PRINT *, 'mm: passing offset of ', k, ' length ', L
           
           CALL WMIDI (buf, Ltot, o_name, 1, L, e_s(k), e_t(k), e_k(k), 
     $        e_c(k), e_p1(k), e_p2(k), e_p3(k), e_v(k), e_g(k), e_r(k),
     $        e_f(k), ind(k), RWE, JWE, usehrv, fault)
           IF (fault .NE. 0) PRINT *, 'WMIDI: error #', fault
         END DO
         STOP   ! success

*-----------------------------------------------------------------------
*               make type zero file
*-----------------------------------------------------------------------
       ELSE IF (option(26)) THEN          ! opt_Z ?
         mnr = 1
         DO i = 1, eact
           e_r(i) =  1                      ! reduce to 1 track
         END DO
         GO TO 50

*-----------------------------------------------------------------------
*           extract configuration
*-----------------------------------------------------------------------
       ELSE IF (option(27)) THEN
         GO TO 60
       END IF

*-----------------------------------------------------------------------
*            analyze input files 
*-----------------------------------------------------------------------
       IF (option(1)) THEN  ! align
         k = 0                      ! count clicks
         DO i = 1, eact
           IF (e_r(i) .EQ. clktrk .AND.
     $          (e_k(i) .LE. 57 .OR. e_k(i) .EQ. 66) ) k = k + 1
         END DO
         IF (k > 0) THEN
           avgtem = FLOAT(k) / tf       ! beats per second
         ELSE
           avgtem = 2.0                 ! default
         END IF
         
         k = 0                       ! clicks
         L = 0                       ! offset into e_t
         tnew = 0.
         DO i = 1, eact
           IF (e_r(i) .EQ. clktrk .AND.
     $          (e_k(i) .LE. 57 .OR. e_k(i) .EQ. 66) ) THEN
             told = tnew
             tnew = e_t(i)
             DO j = L+1, i
               e_t(j) = (k + (e_t(j) - told) / (tnew - told)) / avgtem
             END DO
             k = k + 1
             L = i 
           END IF
         END DO
       END IF
       
       IF (option(7)                 ! genetic algorithm
     $      .OR. option(11)           ! find keys
     $       .OR. option(12)           ! verbose output
     $        .OR. option(16)           ! split by stream
     $         .OR. option(17)           ! quantize
     $          .OR. option(19)           ! steady tempo
     $           .OR. option(20)           ! finding tempo
     $            .OR. option(22)) THEN     ! fake velocity
         
         i = 1       ! offset of first event in next file
         DO k = 1, n_file
           nsteps = CEIL(tend(k) / step)            ! timepoints
           npts = (nsteps-1) / 2 + 1                ! spline points
           IF (nsteps < minstp) npts = 1     ! don't break SPFIT
           j = i                          ! offset of first event in this file
           CALL IBSLE (e_f, eact, k, i) ; i = i + 1
           L = i - j                                ! length
           
*                 Make Note On / Off sequence coherent     
           CALL DUROFF (e_t(j), e_k(j), e_c(j), e_p1(j), e_p2(j), 
     $      e_p3(j), e_v(j), e_g(j), e_f(j), e_r(j), ind, RWE, JWE,
     $      L, psi)

  30       FORMAT (/, '________________________________ analysis of ',
     $             A, ' ________________________________')
           IF (option(12)) THEN
             M = LTRIM(f_name(k))
             PRINT 30, f_name(k)(1:M)
           END IF
           IF (rsrch) THEN
             CALL POLYPHI (drum, e_t(j), e_k(j), e_c(j), e_p1(j),
     $        e_p2(j), e_p3(j), e_v(j), e_g(j), e_f(j), e_r(j), e_u(j), 
     $        ind, RWE, JWE, L, anon, p, fault)
             PRINT *, 'file ', K, ' polyphi returns #', fault
             PRINT *, 'final total score: ', P
           ELSE
             CALL ANALYZ (uprofile, ms, ms2, pkarr, urpar, rsum, uprox,
     $        uqual, uroot, ccarr, mnn, nsteps, npts, step, tend(k), 
     $        option(7), option(11), option(12), option(16),
     $        option(17), option(19), option(20), option(22), 
     $        option(27), usecfg, drum, e_t(j), e_k(j), e_c(j), 
     $        e_p1(j), e_p2(j), e_p3(j), e_v(j), e_g(j), e_f(j), e_r(j),
     $        e_u(j), ind, RWE, JWE, L, ttmp, thz, nt, avgtem, key_t, 
     $        sharps, majmin, keylim, nk, p, psi)
!             PRINT *, 'file ', k, ' analyz returns!' 
           END IF
           IF (anon) STOP 'mm:  Program complete.'
           no = 0         ! count note events
           DO m = j, i-1
             IF (e_k(m) .EQ. 1) no = no + 1
           END DO
           fit_e(k) = p / FLOAT(no)
!           PRINT*, 'p/no of file ', k, ' is ', fit_e(k)
           
         END DO ! next file
       END IF  ! analyze input?
       
*-----------------------------------------------------------------------
*               allocate ouput arrays
*-----------------------------------------------------------------------
       epad = eact + 1
       IF (option(11)) epad = epad + nk
       IF (option(20)) epad = epad + nt
       ALLOCATE (a_s(epad), a_t(epad), a_k(epad), a_c(epad), 
     $  a_p1(epad), a_p2(epad), a_p3(epad), a_v(epad), a_g(epad), 
     $  a_f(epad), a_r(epad), a_u(epad), aind(epad), RWA(3*epad), 
     $  JWA(3*epad), STAT=fault)
       IF (fault .NE. 0) PRINT *, 'mm: trouble allocating out array!'
       a = 0           ! output arrays empty

*-----------------------------------------------------------------------
*            special case for single input file
*-----------------------------------------------------------------------
       IF (n_file .EQ. 1) THEN         
         DO i = 1, eact        ! copy
           a_t(i) = e_t(i)
           a_k(i) = e_k(i)
           a_c(i) = e_c(i)
           a_p1(i) = e_p1(i)
           a_p2(i) = e_p2(i)
           a_p3(i) = e_p3(i)
           a_v(i) = e_v(i)
           a_g(i) = e_g(i)
           a_f(i) = of
           a_r(i) = e_r(i)
         END DO
         a = eact
           
*              add detected key to event array
         IF (option(11)) THEN
           DO i = 1, eact              ! wipe out old key events
             IF (a_k(i) .EQ. 73) a_k(i) = 99
           END DO
           DO i = 1, nk
             a = a + 1
             a_t(a) = key_t(i)
             a_k(a) = 73
             a_c(a) = 0
             a_p1(a) = sharps(i)
             a_p2(a) = majmin(i)
             a_f(a) = of
             a_r(a) = 1
           END DO
         END IF      ! opt_K ?
            
*             wipe out old tempo events
         IF (option(1) .OR. option(20)) THEN          ! option A or T
           DO i = 1, a              
             IF (a_k(i) .EQ. 70) a_k(i) = 99
           END DO
         END IF

*              insert detected tempos into event array         
         IF (option(20)) THEN
           DO i = 1, nt
             a = a + 1
             a_t(a) = ttmp(i)
             a_k(a) = 70
             a_c(a) = 0
             a_p3(a) = thz(i)
             a_f(a) = of
             a_r(a) = 1
           END DO
         END IF                  ! opt_T ?

!!!!!!!!!!!!!!!!!!!!!!!
       IF (dump) THEN
         PRINT *, 'in the one-file block with ', a, ' events:'
         PRINT *, 'time, kind, track, file, channel, par1, par2, ',
     $     'par3, offvel, porta '
         DO i = 1, a
           PRINT 11, a_t(i), a_k(i), a_r(i), a_f(i), a_c(i), a_p1(i), 
     $      a_p2(i), a_p3(i), a_v(i), a_g(i)
         END DO
       END IF
!!!!!!!!!!!!!!!!!!!!!!!!!

*            If splitting voices, find new number of tracks
         IF (option(16)) THEN
           mnr = 1
           DO i = 1, a
             mnr = MAX(mnr, a_r(i))
           END DO
         END IF
         
         IF (.NOT. option(7)) GO TO 40          ! and write out
       END IF               ! one file?
       
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
*            cluster input events e_ into output events a_   
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

 !!!!!!!!!!!!!!! debug diversion
!!!!!!!!!!        GO TO 35
!!!!!!!!!!!!!!!!!!!!!!!!!!!

       CALL blend (n_file, of, option(5), option(7), option(8), 
     $  option(9), option(13), option(15), option(18), option(24), 
     $  option(25), rid, yield, mnr, kul, e_t, e_k, e_c, e_p1, e_p2, 
     $  e_p3, e_v, e_g, e_f, e_r, e_u, ind, RWE, JWE, eact, a_t, a_k, 
     $  a_c, a_p1, a_p2, a_p3, a_v, a_g, a_f, a_r, a, olim)
             
!                DEBUG DUMP
  11   FORMAT (F8.3, I3, I3, I4, I8, I8, I8, F9.4, I8, I8)
       IF (dump) THEN
         PRINT *, 'after calling BLEND(), made ', a, ' events:'
         PRINT *, 'time, kind, track, file, channel, par1, par2, ',
     $     'par3, offvel, porta '
         DO i = 1, a
           PRINT 11, a_t(i), a_k(i), a_r(i), a_f(i), a_c(i), a_p1(i), 
     $      a_p2(i), a_p3(i), a_v(i), a_g(i)
         END DO
       END IF
           
*11111111111111111111111111111111111111111111111111111111111111111111111      
*              analyze output 
*11111111111111111111111111111111111111111111111111111111111111111111111      
       IF (option(7) .OR. option(12)) THEN

*               fix Note-Off times
         CALL duroff (a_t, a_k, a_c, a_p1, a_p2, a_p3, a_v, a_g, a_f, 
     $     a_r, aind, RWA, JWA, a, psi)

         tf = 0. ; no = 0
         DO i = 1, a                  ! time of last event         
           tf = MAX(tf, a_t(i))
           IF (a_k(i) .EQ. 1) no = no + 1          ! count Note-On events
         END DO

!         PRINT *, 'tf=', tf, ' ons=', no     !, ' offs=', n
         
         nsteps = CEIL(tf / step)     ! timepoints
         npts = (nsteps-1) / 2 + 1          ! spline points
         IF (nsteps < minstp) npts = 1  
         IF (option(12)) THEN
           M = LTRIM(o_name)
           PRINT 30, o_name(1:M)
         END IF
         IF (rsrch) THEN
           CALL POLYPHI (drum, a_t, a_k, a_c, a_p1, a_p2, a_p3, a_v, 
     $        a_g, a_f, a_r, a_u, ind, RWA, JWA, a, anon, p, 
     $        fault)
           PRINT *, 'final total score: ', P
         ELSE
           CALL ANALYZ (uprofile, ms, ms2, pkarr, urpar, rsum, uprox,
     $     uqual, uroot, ccarr, no, nsteps, npts, step, tf, option(7),
     $     option(11), option(12), option(16), option(17),
     $     option(19), option(20), option(22), option(27), usecfg, drum,
     $     a_t, a_k, a_c, a_p1, a_p2, a_p3, a_v, a_g, a_f, a_r, a_u,
     $     aind, RWA, JWA, a, ttmp, thz, nt, avgtem, key_t, sharps, 
     $     majmin, keylim, nk, p, psi)       
         END IF
         fit_a = p / FLOAT(no)         ! remember
!         PRINT*, 'p/no of output is ', fit_a
       END IF                      ! analyze output?         
       
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
*               evolve 
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
       IF (option(7)) THEN
       
*             Recalculate KUL to allow for add'l events in A_
         ALLOCATE (usgkrf(n_kind,mnr,n_file+1), STAT=fault)
         IF (fault .NE. 0) PRINT *, 'mm: trouble allocating usgkrf!'
         DO L = 1, n_file+1
           DO j = 1, mnr
             DO k = 1, n_kind
               usgkrf(k,j,L) = 0
             END DO
           END DO
         END DO
         DO i = 1, eact
           k = e_k(i)
           IF (k > 0 .AND. k .LE. n_kind) THEN  ! don't count NoteOff
             j = e_r(i)
             L = e_f(i)
             usgkrf(k,j,L) = usgkrf(k,j,L) + 1
           END IF
         END DO
         DO i = 1, a
           k = a_k(i)
           IF (k > 0 .AND. k .LE. n_kind) THEN
             j = a_r(i)
             L = a_f(i)
             usgkrf(k,j,L) = usgkrf(k,j,L) + 1
           END IF
         END DO
         DO L = 1, n_file+1
           DO j = 1, mnr
             DO k = 1, n_kind
               kul = MAX(kul, usgkrf(k,j,L))
             END DO
           END DO
         END DO
         DEALLOCATE (usgkrf, STAT=fault)
         IF (fault .NE. 0) PRINT *, 'mm: trouble releasing usgkrf!'
         kul = kul * n_sex                    ! worst-case scenario?
         PRINT*, 'mm: computed kul as: ', KUL
                
         CALL GENE (e_t, e_k, e_c, e_p1, e_p2, e_p3, e_v, e_g, e_f, e_r,
     $    e_u, ind, eact, fit_e, n_gen, n_file, of, option(5), 
     $    option(8), option(15), rid, yield, mnr, kul, uprofile, ms, 
     $    ms2, pkarr, urpar, rsum, uprox, uqual, uroot, ccarr, nsteps, 
     $    npts, step, drum, ttmp, thz, nt, avgtem, key_t, sharps, 
     $    majmin, keylim, nk, psi, a_t, a_k, a_c, a_p1, a_p2, a_p3, a_v,
     $    a_g, a_f, a_r, a_u, a, olim, fit_a, fault)
         PRINT *, 'gene returns #', fault 
       END IF
       
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
*               include distinct strings
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!  35   CONTINUE      !!!!! debug destination
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

       eact = eact + 1                 ! insert credits line
       nb = nb + 1
       DO I = 1, LEN(CREDIT)
         CALL BYTPUT (BUF(I), CREDIT(I:I), 0)
       END DO
       E_S(EACT) = 0
       E_T(EACT) = 0.
       E_U(EACT) = 0.
       E_K(EACT) = 61
       E_C(EACT) = 0
       E_P1(EACT) = 1
       E_P2(EACT) = LEN(CREDIT)
       E_P3(EACT) = 0.
       E_V(EACT) = 0
       E_G(EACT) = 0
       E_F(EACT) = of
       E_R(EACT) = 1

!!!!!!!!!!!!!!!!!! debug input to blelim
  37   FORMAT (F8.3, I3, I3, I9, I9, $)
  38   FORMAT (A1, $)
  39   FORMAT ()
       IF (dump) THEN
         PRINT *, 'before blelim there are blobs:'
         K = 0  
         DO I = 1, EACT
           J = E_K(I)
          CALL IBSLE (BKIN, 12, J, L)
           IF (L > 0) THEN
             IF (BKIN(L) .EQ. J) THEN
               K = K + 1
               M = E_P1(I)
               L = E_P2(I)
               PRINT 37, e_t(i), e_K(i), e_c(i), e_p1(i), e_p2(i)
               PRINT 38, ' '
               DO J = M, M+L-1
                 PRINT 38, CHAR(BUF(J))
               END DO
               PRINT 39
             END IF
           END IF
         END DO
         PRINT *, 'counted ', K, ' blobs'
       END IF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!       
      
       CALL BLELIM (BUF, Ltot, of, mnr, nb,
     $  e_t, e_k, e_c, e_p1, e_p2, e_f, e_r, eact, 
     $  a_t, a_k, a_c, a_p1, a_p2, a_f, a_r, a)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       IF (dump) THEN
         PRINT *, 'blelim returns, now blobs are:'
         K = 0
         DO I = 1, A
           J = a_K(I)
           
           CALL IBSLE (BKIN, 12, J, L)
           IF (L > 0) THEN
             IF (BKIN(L) .EQ. J) THEN
               K = K + 1
               M = a_P1(I)
               L = a_P2(I)
               PRINT 37, a_t(i), a_K(i), a_c(i), a_p1(i), a_p2(i)
               PRINT 38, ' '
               DO J = M, M+L-1
                 PRINT 38, CHAR(BUF(J))
               END DO
               PRINT 39
             END IF
           END IF
         END DO
         PRINT *, 'counted ', K, ' blobs'
       END IF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!DEBUG DUMP
       IF (dump) THEN
         PRINT *, 'after calling BLELIM(), there are ', a, ' events:'
         PRINT *, 'time, kind, track, file, channel, par1, par2, par3 '
         DO i = 1, a
           PRINT *, a_t(i), a_k(i), a_r(i), a_f(i), a_c(i), a_p1(i), 
     $        a_p2(i), a_p3(i)
         END DO
         PRINT *, 'mnr: ', mnr, ' mnn: ', mnn, ' kul:', kul, ' nb', nb
       END IF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       
*///////////////////////////////////////////////////////////////////////
  40   CONTINUE            ! write the output MIDI file in a_
*///////////////////////////////////////////////////////////////////////
*               fix Note-Off times
       IF (.NOT. option(14))
     $    CALL duroff (a_t, a_k, a_c, a_p1, a_p2, a_p3, a_v, a_g, a_f, 
     $   a_r, aind, RWA, JWA, a, psi)
     
!!!!!!!!!!!!!!!!!!!!!!!!!!
       IF (dump) THEN
         PRINT *, 'at line 40 with ', a, ' events:'
         PRINT *, 'time, kind, track, file, channel, par1, par2, ',
     $     'par3, offvel, porta '
         DO i = 1, a
           PRINT 11, a_t(i), a_k(i), a_r(i), a_f(i), a_c(i), a_p1(i), 
     $      a_p2(i), a_p3(i), a_v(i), a_g(i)
         END DO
         PRINT *, 'mnr: ', MNR
       END IF
!!!!!!!!!!!!!!!!!!!!!!!!!        

       CALL WMIDI (buf, Ltot, o_name, mnr, a, a_s, a_t, a_k, a_c,
     $  a_p1, a_p2, a_p3, a_v, a_g, a_r, a_f, aind, RWA, JWA,
     $  usehrv, fault)
  45   FORMAT ('mm:  wrote file ', A)
       IF (fault .EQ. 0) THEN
         PRINT 45, o_name(1:LTRIM(o_name))
       ELSE
         PRINT *, 'WMIDI: error #', fault
       END IF
       STOP  ! success
       
*11111111111111111111111111111111111111111111111111111111111111111111111
  50   CONTINUE             ! write the output MIDI file in e_
*11111111111111111111111111111111111111111111111111111111111111111111111
!!       PRINT *, 'at line 50!'
       IF (.NOT. option(14))
     $    CALL DUROFF (e_t, e_k, e_c, e_p1, e_p2, e_p3, e_v, e_g, e_f,
     $     e_r, ind, RWE, JWE, eact, psi)
     
       CALL WMIDI (buf, Ltot, o_name, mnr, eact, e_s, e_t, e_k, e_c,
     $  e_p1, e_p2, e_p3, e_v, e_g, e_r, e_f, ind, RWE, JWE, 
     $  usehrv, fault)
       IF (fault .EQ. 0) THEN
         PRINT 45, o_name(1:LTRIM(o_name))
       ELSE
         PRINT *, 'WMIDI: error #', fault
       END IF
       STOP        ! success
     
*-----------------------------------------------------------------------      
  60   CONTINUE      !  extract configuration data from multiple files
*-----------------------------------------------------------------------
*        analyze each file
       i = 1
       DO k = 1, n_file         
         j = i
         CALL IBSLE (e_f, eact, k, i) ; i = i + 1
         L = i - j

         nsteps = CEIL(tend(k) / step)      ! timepoints
         npts = (nsteps-1) / 2 + 1          ! spline points
         IF (nsteps < minstp) npts = 1      ! don't overfit just a few steps
         IF (option(22)) THEN
           M = LTRIM(f_name(k))
           PRINT 30, f_name(k)(1:M)
         END IF
         CALL ANALYZ (uprofile, ms, ms2, pkarr, urpar, rsum, uprox,
     $     uqual, uroot, ccarr, mnn, nsteps, npts, step, tend(k), 
     $     option(7), option(11), option(12), option(16),
     $     option(17), option(19), option(20), option(22), option(27),
     $     usecfg, drum, e_t(j), e_k(j), e_c(j), e_p1(j), e_p2(j), 
     $     e_p3(j), e_v(j), e_g(j), e_f(j), e_r(j), e_u(j), ind, RWE, 
     $     JWE, L, ttmp, thz, nt, avgtem, key_t, sharps, majmin, keylim,
     $     nk, p, psi)
         PRINT *, 'ANALYZ returns!'
       END DO

*-----------------------------------------------------------------------
*       save probabilities of collection
*-----------------------------------------------------------------------
       PRINT *, 'taking averages...'
       CALL MKPROF (uprofile, uvar, ms, ms2)
       CALL MKRPAR (rsum, urpar)
       CALL MKPQR (uprox, uqual, uroot)
       
       PRINT *, 'opening file...'
       iou = IOUNIT()
       OPEN (UNIT=iou, FILE=c_name, STATUS='NEW', 
     $            FORM='FORMATTED', ACCESS='SEQUENTIAL', ERR=90)
       REWIND (UNIT=iou, ERR=90)

*              config file preface
  62   FORMAT ('* ', A, ' - config file for MIXMIDI.', /,
     $   '* Comments begin with !, %, or *', /,
     $   '* You may edit this file.  Most of these values represent ',
     $   'probabilities and should be small positive numbers.', /,
     $   '* Please do not leave any values undefined or set ',
     $   'anything to a negative number.')
       L = LTRIM(c_name)
       WRITE (UNIT=iou, FMT=62, ERR=90) c_name(1:L)
       
  65   FORMAT (A, G18.8)
       
       i = 0                ! count through labels
       DO k = 0, 1
         DO j = 0, 11
           i = i + 1
           WRITE (UNIT=iou, FMT=65, ERR=90) cfglab(i), uprofile(j,k)
         END DO
       END DO
       i = i + 1
       WRITE (UNIT=iou, FMT=65, ERR=90) cfglab(i), uvar
       DO j = 1, 8
         i = i + 1
         WRITE (UNIT=iou, FMT=65, ERR=90) cfglab(i), urpar(j)
       END DO
       DO j = 0, 6
         i = i + 1
         WRITE (UNIT=iou, FMT=65, ERR=90) cfglab(i), uprox(j)
       END DO
       DO k = 0, 1
         DO j = 1, num_q
           i = i + 1
           WRITE (UNIT=iou, FMT=65, ERR=90) cfglab(i), uqual(j,k)
         END DO
       END DO
       DO k = 0, 1
         DO j = 0, 11
           i = i + 1
           WRITE (UNIT=iou, FMT=65, ERR=90) cfglab(i), uroot(j,k)
         END DO
       END DO
       CLOSE (UNIT=iou, ERR=90)
       PRINT 45, c_name(1:LTRIM(c_name))
       STOP  ! success

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  70   CONTINUE                  ! license bail
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!  71   FORMAT ('METIS - Serial Graph Partitioning and Fill-reducing ',
!     $  'Matrix Ordering', /,
!     $  'by George Karypis. Copyright (c) 1995-2008 Regents of the ',
!     $  'University of Minnesota', /,
!     $  'See LICENSE-2.0.txt', /)
!       IF (LINUX) PRINT 71
!       
!  72   FORMAT (
!     $  'Graclus -- Efficient graph clustering software for ',
!     $  'normalized cut and ratio association on undirected graphs.', /,
!     $  'Copyright(c) 2008 Brian Kulis, Yuqiang Guan (version 1.2)', /,
!     $  'See gpl-3.0.txt', /)
!       IF (LINUX) PRINT 72
!  
!  73   FORMAT ('Subroutines from ARPACK, LAPACK, and BLAS are subject ',
!     $  'to the BSD license.  See source code for details.')
!       PRINT 73   
     
  74   FORMAT ('MIXMIDI - mix or manipulate symbolic muscial data', /,
     $  'by Andy Allinger, 2011-2017, released to the public domain', /,
     $  'This program may be used by any person for any purpose.', /)
       PRINT 74
  
       STOP
       
*///////////////////////////////////////////////////////////////////////
  80   CONTINUE              ! usage bail
*///////////////////////////////////////////////////////////////////////
       PRINT 85
  85  FORMAT ('usage: mm [-opt] <input1.mid> [input2.mid] <output.mid>')
  86  FORMAT (T6, A, T11, A)
  
       IF (gethelp) THEN 
         PRINT 86, '-A', 'align times to click track'
         PRINT 86, '-B', 'all files begin at time 0'
         PRINT 86, '-C', 'separate by channel'
         PRINT 86, '-D', 'specify drum channels'
         PRINT 86, '-E', 'mix by expectation maximization method (slow)'
         PRINT 86, '-F', 'scale times so files finish together'
         PRINT 86, '-G', 'run genetic algorithm (slow)'
         PRINT 86, '-H', 'use alternative initial clusters'
         PRINT 86, '-I', 'mix, yield the intersection of input'
         PRINT 86, '-J', 'add jitter to input'
         PRINT 86, '-K', 'detect key signatures'
         PRINT 86, '-L', 'long form output'
         PRINT 86, '-M', 'mix using meter information'
         PRINT 86, '-N', 'permit overlapping notes'
         PRINT 86, '-O', 'tempo, time/key signature from track 1 only'
         PRINT 86, '-P', 'separate input by counterpoint analysis'
         PRINT 86, '-Q', 'quantize output'
         PRINT 86, '-R', 'mix, omit data from specified file(s)'
         PRINT 86, '-S', 'force steady tempo'
         PRINT 86, '-T', 'detect tempo changes'
         PRINT 86, '-U', 'combine tracks into one file'
         PRINT 86, '-V', 'enhance velocity'
         PRINT 86, '-W', 'disunion - separate tracks to files'
         PRINT 86, '-X', 'mix, yield mutual exclusion of input'
         PRINT 86, '-Y', 'mix, with a user-specified yield fraction'
         PRINT 86, '-Z', 'combine tracks into a type-0 file'
         PRINT 86, '-$', 'extract configuration data from files'
         PRINT 86, '-?', 'this help message'
       END IF
       STOP

*\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  90     CONTINUE              ! fatal errors
*\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
       STOP 'file I/O error'
      END ! of mm



*######################################################################
*  blend - mix MIDI files by data clustering
*######################################################################
*__Name_________Type_______I/O_____Description_________________________
*  n_file       INTEGER    in      # of input files
*  of           INTEGER    in      ID of blended file
*  opt_E        LOGICAL    in      expectation maximization
*  opt_G        LOGICAL    in      running a genetic algorithm?
*  opt_H        LOGICAL    in      hyperplane partitions
*  opt_I        LOGICAL    in      keep clusters with events from every file
*  opt_M        LOGICAL    in      consider meter information
*  opt_O        LOGICAL    in      use arithmetic mean
*  opt_R        LOGICAL    in      remove clusters with events from given files
*  opt_X        LOGICAL    in      keep clusters with events from 1 file
*  opt_Y        LOGICAL    in      use the yield rate (instead of median)
*  rid[n_file]  LOGICAL    in      source files to discard clusters from
*  yield        REAL       in      yield rate
*  mnr          INTEGER    in      maximum number of tracks
*  kul          INTEGER    in      most events of any kind in any track
*  e_t[e]       REAL       in      event times
*  e_k[e]       INTEGER    in      event kinds
*  e_c[e]       INTEGER    in      event channel
*  e_p1[e]      INTEGER    in      event parameter #1
*  e_p2[e]      INTEGER    in      event parameter #2
*  e_p3[e]      REAL       in      event parameter #3
*  e_v[e]       INTEGER    in      event off-velocity
*  e_g[e]       INTEGER    in      event portamento prefix
*  e_f[e]       INTEGER    in      event source/destination file
*  e_r[e]       INTEGER    in      event track
*  e_u[e]       REAL       in      event metrical times
*  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 array
*  a_t[e]       REAL       out     blended times
*  a_k[e]       INTEGER    out     blended kinds
*  a_c[e]       INTEGER    out     blended channel
*  a_p1[e]      INTEGER    out     blended data #1
*  a_p2[e]      INTEGER    out     blended data #2
*  a_p3[e]      REAL       out     blended data #3
*  a_v[e]       INTEGER    out     blended off-velocity
*  a_g[e]       INTEGER    out     blended portament prefix
*  a_f[e]       INTEGER    out     new file ID
*  a_r[e]       INTEGER    out     blended tracks
*  a            INTEGER    out     length of blended event list
*  olim         INTEGER    out     longest possible length of blended events
*
*#######################################################################
      SUBROUTINE blend (n_file, of, opt_E, opt_G, opt_H, opt_I, opt_M, 
     $  opt_O, opt_R, opt_X, opt_Y, rid, yield, mnr, kul, 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, 
     $  a_t, a_k, a_c, a_p1, a_p2, a_p3, a_v, a_g, a_f, a_r, a, olim)
      
       IMPLICIT NONE
       INTEGER n_file, of, mnr, kul, e_k, e_c, e_p1, e_p2, e_v, e_g, 
     $  e_f, e_r, ind, JSW, e,
     $  a_k, a_c, a_p1, a_p2, a_v, a_g, a_f, a_r, a, olim
       REAL yield, e_t, e_p3, e_u, RSW, a_t, a_p3
       LOGICAL opt_E, opt_G, opt_H, opt_I, opt_M, opt_O, opt_R, opt_X,
     $  opt_Y, rid
       DIMENSION rid(n_file), 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), 
     $  ind(e), RSW(3*e), JSW(3*e), a_t(e), a_k(e), a_c(e), a_p1(e), 
     $  a_p2(e), a_p3(e), a_v(e), a_g(e), a_f(e), a_r(e)

*            constants
       INTEGER c_tries, n_kind, plim 
       REAL skpar, popmin
       PARAMETER (
     $            c_tries = 10,       ! must match cluster.f
     $            n_kind = 90,        ! must match midifile.f
     $            plim = 8,           ! row bound of X and C
     $            popmin = 0.0001,    ! don't create event less than this
     $            skpar = 0.95 )      ! kmin this fraction or less of kdef
                   
*         local variables  
       INTEGER  
     $         alg,                 ! select a clustering algorithm
     $         allerr,              ! memory allocation error code
     $         CAT(plim),           ! categories each categorical var
     $         cattot,              ! total categories
     $         ctran(16),           ! translation table channel to ID
     $         g0, g1, h0, h1,      ! offsets           
     $         h, i, j, k, L,       ! count files, events, trks, kinds, clusts
     $         ifault,              ! exit code
     $         kmin, kdef, kmax,    ! how many clusters to make
     $         kuse(0:n_kind),      ! # of events of given kind
     $         n,                   ! how many events of a particular kind
     $         p,                   ! how many dimensions of data
     $         opt,                 ! clustering options
     $         srep                 ! # distinct files in a cluster
               
       REAL 
     $        ave,                       ! events of some kind per file
!     $        RANG,                      ! normal random number generator
     $        T(plim),                   ! modulo arithmetic periods
     $        W(plim)                    ! importance weights
       
       LOGICAL keep                      ! keep this cluster
            
*                        allocatable arrays
       INTEGER, DIMENSION (:), ALLOCATABLE ::
     $         kev,          ! count of events, each file
     $         ftran,        ! translation table file to ID 
     $         iperm,        ! permutation vector
     $         livec,        ! live clusters array
     $         livex,        ! live points array
     $         ptran,        ! translation table of event data
     $         Z             ! cluster memberships
       
       INTEGER, DIMENSION (:,:), ALLOCATABLE ::
     $     kcens,             ! # of events of given kind and file
     $     Zsave              ! saved cluster memberships
     
       REAL, DIMENSION (:), ALLOCATABLE ::
     $        POP,                       ! cluster populations
     $        RWORK,                     ! workspace for finding kdef
     $        SHORTX                     ! shortest distance to a point
        
       REAL, DIMENSION (:,:), ALLOCATABLE ::
     $        C,                  ! cluster centers
     $        TAL,                ! categorical variable tally
     $        WORK,               ! temporary vector
     $        X                   ! data array for clustering
           
       LOGICAL, DIMENSION (:), ALLOCATABLE :: rep
     
       REAL tarray(2), result            ! timing
       SAVE T, W
       
*######################################################################
*          begin
*######################################################################
*             request memory
       ALLOCATE (kev(n_file), ftran(n_file), ptran(kul), Z(kul), 
     $  kcens(n_file,0:n_kind), POP(kul), C(plim,kul), RWORK(n_file),
     $  WORK(kul,2), X(plim,kul), rep(n_file), STAT=allerr)
       IF (allerr .NE. 0) THEN
         PRINT *, 'blend:  trouble allocating memory'
         RETURN
       END IF
       
*        clustering options       
       opt = 1                          ! robust mode is default
       IF (opt_O) opt = opt - 1         ! turn off option
       IF (opt_G) opt = opt + 2         ! brief mode
       IF (opt_H) opt = opt + 4         ! hyperplane
       IF (opt_E) THEN
         alg = 1         ! common algorithm
       ELSE
         alg = 0         ! isodata
       END IF

*                 sort by time
       DO i = 1, e ; ind(i) = i ; END DO
       CALL MSORTR (e_t, ind, e, RSW, JSW)
       CALL IORDER (e_k, 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_f, ind, e)
       CALL IORDER (e_r, ind, e)
       CALL RORDER (e_u, ind, e)
        
*                  sort by kind
       DO i = 1, e ; ind(i) = i ; END DO
       CALL RSORTI (e_k, ind, e, 7, JSW)         ! assumes kinds are [0,127] !
       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_f, ind, e)
       CALL IORDER (e_r, ind, e)
       CALL RORDER (e_u, ind, e)
       
*                 sort by track
       DO i = 1, e ; ind(i) = i ; END DO
       CALL RSORTI (e_r, ind, e, 16, JSW)       ! OK, allows tracks up to 65535
       CALL RORDER (e_t, ind, e)
       CALL IORDER (e_k, 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_f, ind, e)
       CALL RORDER (e_u, ind, e)
       
*         periods and weights shared by all event kinds
       T(1) = 0.        ! time
       T(2) = -1.       ! channel
       T(3) = -3.       ! source file
       
************************************************************************
* Weights are based on inverse deviations measured from the Maple Leaf corpus, 
* based on five performances of the Maple Leaf Rag of Scott Joplin, Bill Flynt,
* Gary Rogers, Alessandro Simonetto, and Mario Verehrer.  
* Each performed note was either matched to a note in the score, or else
* marked as stray.
* Refer to file:  maple.csv
*    index fraction   121.7
*    time               2.66
*    metrical time      9.97
*    pitch              0.313
*    pitch % 12         1.823
*    velocity           0.000331
*    duration          11.76
*
* From the Pathetique Sonata Op.13 No.3 theme, weights are:
*   index fraction   112.3
*   time               3.33
*   metrical time      4.82
*   pitch              ###
*   pitch % 12         +Inf
*   velocity           0.0003
*   duration          12.67
*
************************************************************************
       W(1) = 3.
       W(2) = 1.
       W(3) = 0.9

       CAT(1) = 0

*######################################################################
*                 for each track
*######################################################################
       a = 0       ! no new events yet
       olim = 0
       h1 = 0
       DO j = 1, mnr
         h0 = h1
         CALL IBSLE (e_r, e, j, h1)    ! last index for events on this track
         IF (e_r(h1) .NE. j) CYCLE     ! empty track ?
         
*                  count event kinds on this track
         DO k = 0, n_kind
           DO h = 1, n_file
             kcens(h,k) = 0
           END DO
         END DO
                   
         DO i = h0+1, h1
           k = e_k(i)
           IF (k < 0 .OR. k > n_kind) CYCLE
           h = e_f(i)
           kcens(h,k) = kcens(h,k) + 1
         END DO
               
!!           DEBUG:  what kind of events are there?
!         PRINT *, 'e_k: ', e_k
           
         DO k = 0, n_kind
           kuse(k) = 0
           i = 0
           DO h = 1, n_file
             kuse(k) = kuse(k) + kcens(h,k)
             i = MAX(i, kcens(h,k))

!!!!!!!!!!!!!!!!!!!!!! more debugging
!           PRINT *, 'kcens for file ', H, ' kind ', K, ': ', KCENS(H,K)

           END DO
           olim = olim + i
         END DO
         
!              DEBUG
!!        PRINT *, 'kuse: ', kuse         
         
*######################################################################
*               for each kind of event
*######################################################################
         CALL IBSLE (e_k(h0+1), h1-h0, 0, g1)     ! find index of last Note-Off
         g1 = g1 + h0
         DO k = 1, n_kind
         
!!!!!!!!!!!!!!!!!! debugging
!           PRINT *, 'in blend with track: ', j, ' and kind ', k
                    
           IF (kuse(k) .EQ. 0) CYCLE
           g0 = g1
           CALL IBSLE (e_k(h0+1), h1-h0, k, g1)
           g1 = g1 + h0
           IF (e_k(g1) .NE. k) CYCLE

*                skip blobs
           IF ( k .EQ. 58 .OR. k .EQ. 59
     $       .OR. (k .GE. 61 .AND. k .LE. 69) 
     $        .OR. k .EQ. 75 ) CYCLE   

*              Note On
           IF (k .EQ. 1) THEN 
             p = 7
             T(4) =  0.             ! pitch
             T(5) = 12.             ! pitch, modulo
             T(6) =  0.             ! velocity (hi-res)
             T(7) =  0.             ! duration
             W(4) = 1.
             W(5) = 2.
             W(6) = 3.E-4
             W(7) = 13.

             CAT(4) = 0
             CAT(5) = 0
             CAT(6) = 0
             CAT(7) = 0

*             Aftertouch
           ELSE IF (k .EQ. 2) THEN
             p = 5
             T(4) = 0.            ! pitch
             T(5) = 0.            ! velocity (lo-res)
             W(4) = 0.5
             W(5) = 0.03
             CAT(4) = 0
             CAT(5) = 0
             
*            kinds with one categorical parameter             
           ELSE IF (k .EQ. 3 .OR. k .EQ. 55 .OR. k .EQ. 60   ! bank, patch, seq
     $       .OR. k .EQ. 74 .OR. k .EQ. 79 .OR. k .EQ. 80) THEN   ! xmf, tuning
             p = 4
             T(4) = -1.
             W(4) = 2.
             
*            should not be present
           ELSE IF (k .EQ. 99 .OR. k .EQ. 8 .OR. k .EQ. 39 
     $              .OR. k .EQ. 40 .OR. k .EQ. 46 .OR. k .EQ. 48) THEN
             PRINT *, 'blend: warning: event kind: ', k
             CYCLE
             
*            controllers with 7-bit range (includes pedals and some booleans)
           ELSE IF ((k .GE. 19 .AND. k .LE. 45) .OR. k .EQ. 51
     $       .OR. k .EQ. 53 .OR. k .EQ. 56) THEN
             p = 4
             T(4) = 0.
             W(4) = 0.03
             CAT(4) = 0
             
*           controllers with 14-bit range
           ELSE IF ((k .GE. 4 .AND. k .LE. 18) .OR. k .EQ. 57 
     $        .OR. k .EQ. 77 .OR. (k .GE. 81 .AND. k .LE. 90)) THEN
             p = 4
             T(4) = 0.
             W(4) = 0.0002
             CAT(4) = 0    
             
*             kinds with two data
           ELSE IF (k .EQ. 47) THEN        ! non-registered parameter
             p = 5
             T(4) = -1.
             T(5) = 0.
             W(4) = 4.
             W(5) = 0.0001
             CAT(5) = 0

           ELSE IF (k .EQ. 54) THEN       ! mono/poly
             p = 5
             T(4) = 0.
             T(5) = 0.
             W(4) = 0.015
             W(5) = 1.
             CAT(4) = 0
             CAT(5) = 0
           
           ELSE IF (k .EQ. 72) THEN        ! time signature
             p = 5
             T(4) = 0.
             T(5) = 0.
             W(4) = 9.
             W(5) = 3.
             CAT(4) = 0
             CAT(5) = 0
           
           ELSE IF (k .EQ. 73) THEN       ! key signature
             p = 5
             T(4) = 12.
             T(5) = 0.     
             W(4) = 5.
             W(5) = 1.5
             CAT(4) = 0
             CAT(5) = 0
             
*             one continous datum            
           ELSE IF (k .EQ. 70) THEN        ! tempo (Hz)
             p = 4
             T(4) = 0.
             W(4) = 4.
             CAT(4) = 0
             
           ELSE IF (k .EQ. 71) THEN        ! SMPTE offset (s)
             p = 4
             T(4) = 0.
             W(4) = 1.
             CAT(4) = 0
             
           ELSE IF (k .EQ. 76) THEN        ! pitch bend range (cents)
             p = 4
             T(4) = 0.
             W(4) = 0.01
             CAT(4) = 0
             
           ELSE IF (k .EQ. 78) THEN        ! coarse tuning (semitones)
             p = 4
             T(4) = 0.
             W(4) = 1.
             CAT(4) = 0
             
*             no data
           ELSE IF (k .EQ. 49 .OR. k .EQ. 50 .OR. k .EQ. 52) THEN
             p = 3

           ELSE
             PRINT *, 'blend:  unrecognized kind ', k
             DEALLOCATE (kev, ftran, ptran, Z, kcens, POP, C, RWORK, 
     $         WORK, X, rep, STAT=allerr)
             RETURN
             
           END IF

*=======================================================================
*     translate channel and file # to small consecutive integers
*=======================================================================
           CALL SUCCOD (e_c(g0+1), ctran, ind, g1-g0, 16, CAT(2))
           CALL SUCCOD (e_f(g0+1), ftran, ind, g1-g0, n_file, CAT(3))
           
!!!!!!!!! debugging:           
!!           PRINT *, 'ctran is: ', ctran, ' with cat[3]: ', CAT(3)
!!           PRINT *, 'ftran is: ', ftran, ' with cat[4]: ', CAT(4)
!!!!!!!!!!!!!!!!!!!!!!
           
*                   categorical event data           
           IF (k .EQ. 3 .OR. k .EQ. 47 .OR. k .EQ. 55 .OR. k .EQ. 60  
     $       .OR. k .EQ. 74 .OR. k .EQ. 79 .OR. k .EQ. 80)
     $         CALL SUCCOD (e_p1(g0+1), ptran, ind, g1-g0, kul, CAT(4))
     
************************************************************************
*             Metrical time
************************************************************************
           IF (opt_M) THEN
             p = p + 1
             T(p) = 1.
             W(p) = 5.
             CAT(p) = 0
           END IF

*#######################################################################
*                for each event
*#######################################################################
           n = 0                           ! fresh count of events in X[]
           DO h = 1, n_file                ! fresh per-file counts
             kev(h) = 0
           END DO
           
           DO i = g0+1, g1
             n = n + 1
             h = e_f(i)
             kev(h) = kev(h) + 1
             
*               fill X[]
             X(1,n) = e_t(i)                      ! real time
             
             L = e_c(i)
             CALL IBSLE (ctran, CAT(2), L, h)
             IF (h < 1 .OR. h > CAT(2)) THEN
               PRINT *, 'blend: bad channel ID, h= ', h, ' L=', L
             END IF
             X(2,n) = FLOAT(h)                    ! channel ID

             L = e_f(i)
             CALL IBSLE (ftran, CAT(3), L, h)
             IF (h < 1 .OR. h > CAT(3)) THEN
               PRINT *, 'blend:  bad file ID!, h= ', h, ' L=', L
             END IF
             X(3,n) = FLOAT(h)                    ! file ID

             IF (opt_M) X(p,n) = e_u(i)         ! metrical time

*               notes
             IF (k .EQ. 1) THEN 
               X(4,n) = FLOAT(e_p1(i))            ! pitch
               X(5,n) = 7. * FLOAT(e_p1(i))       ! cyclic pitch
               X(6,n) = FLOAT(e_p2(i))            ! velocity
               X(7,n) = e_p3(i)                   ! duration

*                one (continuous) integer datum
             ELSE IF ( (k .GE. 4 .AND. k .LE. 45) .OR. k .EQ. 51 
     $         .OR. k .EQ. 53 .OR. k .EQ. 56 .OR. k .EQ. 57 
     $          .OR. k .EQ. 76 .OR. k .EQ. 77 .OR. k .EQ. 78
     $           .OR. (k .GE. 81 .AND. k .LE. 90) ) THEN
               X(4,n) = FLOAT(e_p1(i))
               
*                one real datum
             ELSE IF (k .EQ. 70 .OR. k .EQ. 71) THEN
               X(4,n) = e_p3(i)
             
*                categorical datum
             ELSE IF (k .EQ. 3 .OR. k .EQ. 55 .OR. k .EQ. 60
     $            .OR. k .EQ. 74 .OR. k .EQ. 79 .OR. k .EQ. 80) THEN
               L = e_p1(i)
               CALL IBSLE (ptran, CAT(4), L, h)
               IF (h < 1 .OR. h > CAT(4)) THEN
                 PRINT *, 'blend: bad parameter index!'
               END IF
               X(4,n) = FLOAT(h)
             
*               kinds with two data
             ELSE IF (k .EQ. 2 .OR. k .EQ. 54 
     $                 .OR. k .EQ. 72 .OR. k .EQ. 73) THEN
               X(4,n) = FLOAT(e_p1(i))
               X(5,n) = FLOAT(e_p2(i))
               
!!!!!!!!!           debug time $ key events!?     
!               IF (k .EQ. 72) PRINT *, 'blend: inserting time sig ',
!     $   'event: ', X(4,n), '/', X(5,n)
!     
!               IF (k .EQ. 73) PRINT *, 'blend inserting key sig ',
!     $    'event: ', X(4,n), ':', X(5,n)
!!!!!!!!!!!!!!!!!!!!!!!!     

*                  NRPN
             ELSE IF (k .EQ. 47) THEN
               L = e_p1(i)
               CALL IBSLE(ptran, CAT(4), L, h)
               X(4,n) = FLOAT(h)
               X(5,n) = FLOAT(e_p2(i))
               
             ELSE IF (k .EQ. 49 .OR. k .EQ. 50 .OR. k .EQ. 52) THEN
               CONTINUE

             ELSE
               PRINT *, 'blend: unexpected event type ?!?!', k
               
             END IF
           END DO  ! next i
           
*=======================================================================
*               decide how many clusters                 
*=======================================================================
           IF (opt_Y) THEN                   ! constant fraction
             kdef = INT(yield * n)
           ELSE                              ! median
             DO h = 1, n_file
               RWORK(h) = FLOAT(kcens(h,k))               
             END DO
             CALL MEDIAN (RWORK, n_file, ave)
             kdef = NINT(ave)
           END IF
           IF (kdef .EQ. 0) THEN         ! some probability of making event 
             ave = FLOAT(kuse(k)) / FLOAT(n_file)
             IF (RAND(0) < ave) kdef = 1
           END IF
           IF (kdef < 1) CYCLE        ! nothing to do

           IF (opt_Y) THEN
             kmin = 1
             kmax = n
           ELSE
             kmin = n
             kmax = 1
             DO h = 1, n_file
               kmin = MIN(kmin, kcens(h,k))
               kmax = MAX(kmax, kcens(h,k))   ! don't exceed OLIM
             END DO
             kmin = MIN(kmin, NINT(SKPAR * kdef))  ! allow to delete a few
           END IF
           
*                 for genetic algorithm
           IF (opt_G) THEN
!!!             kdef = NINT(kdef + (kmax - kmin) * (RANG() / 10.)) ! randomize
!!             kdef = kmax
             CONTINUE
           END IF
           
*                allowable range of # of clusters
           kmin = MIN(MAX(1, kmin), n)
           kmax = MIN(MAX(1, kmax), n)
           IF (kmin > kmax) THEN                   ! swap
             L = kmin ; kmin = kmax ; kmax = L
           END IF
           kdef = MIN(MAX(kmin, kdef), kmax)
           
*#######################################################################
*           apply data clustering subroutine
*#######################################################################
!!               DEBUG:
       CALL DTIME(tarray, result)
!       PRINT *, 'call iclust track ', j, ' kind ', k, ' # events:', n,
!     $ ' dims:', p, ' clusters: ', kmin, '..', kdef, '..', kmax,
!     $  ' obs:', n_file           
!           CALL ICLUST (X, plim, p, n, T, W, CAT, C, kmin, kdef, kmax,
!     $            Z, POP, opt, alg, ifault)
!           PRINT *, 'iclust returns #', ifault, ' made ', kdef, 
!     $       ' events in ', result, ' seconds'
     
           cattot = 0
           DO h = 1, p
             cattot = cattot + CAT(h)
           END DO
           IF (cattot .EQ. 0) cattot = 1
           ALLOCATE (IPERM(n), LIVEX(n), LIVEC(kmax), TAL(cattot,kmax),
     $       ZSAVE(n,c_tries), SHORTX(n), STAT=allerr)
           IF (allerr .NE. 0) PRINT *, 'blend: trouble allocating !!'
     
!       PRINT *, 'call jclust track ', j, ' kind ', k, ' # events:', n,
!     $ ' dims:', p, ' clusters: ', kmin, '..', kdef, '..', kmax,
!     $  ' obs:', n_file

           CALL JCLUST (X, plim, p, n, T, W, CAT, cattot, n_file, C, 
     $      kmin, kdef, kmax, TAL, Z, POP, opt, alg, ZSAVE, IPERM, 
     $      LIVEX, LIVEC, SHORTX, WORK, ifault)
           CALL DTIME(tarray, result)
           IF (IFAULT .NE. 0) THEN
             PRINT *, 'jclust returns #', ifault, ' made ', kdef, 
     $         ' events in ', result, ' seconds'
           END IF

*               option E fails
           IF (ifault .EQ. 13) THEN
             CALL JCLUST (X, plim, p, n, T, W, CAT, cattot, n_file, C, 
     $         kmin, kdef, kmax, TAL, Z, POP, opt, 0, 
     $         ZSAVE, IPERM, LIVEX, LIVEC, SHORTX, WORK, ifault)
             CALL DTIME(tarray, result)
             PRINT *, 'jclust returns #', ifault, ' made ', kdef, 
     $       ' events in ', result, ' seconds'
           END IF

*              Select instead of averaging           
           IF (opt_G) CALL XOVER (X, plim, p, n, C, kdef, Z, POP, IPERM)
           
           DEALLOCATE (IPERM, LIVEX, LIVEC, TAL, ZSAVE, SHORTX, 
     $       STAT=allerr)
           IF (allerr .NE. 0) PRINT *, 'blend: trouble releasing mem!'
           IF (ifault .NE. 0) CYCLE     ! unable to blend, no events made
           
*#######################################################################
*                for each cluster
*#######################################################################
           DO L = 1, kdef 
             srep = 0     ! number distinct files
             IF (opt_I .OR. opt_R .OR. opt_X) THEN
               DO h = 1, n_file       ! mark which original files are present
                 rep(h) = .FALSE.
               END DO
               DO i = 1, n
                 IF (Z(i) .EQ. L) rep(e_f(g0+i)) = .TRUE.
               END DO
             
               DO h = 1, n_file
                 IF (rep(h)) srep = srep + 1
               END DO
             END IF                ! option (I or R or X)?
             
             IF (opt_I) THEN        ! require all files
               keep = srep .EQ. n_file
             ELSE IF (opt_R) THEN       ! forbid specific files
               keep = .TRUE.
               DO h = 1, n_file
                 IF (rep(h) .AND. rid(h)) keep = .FALSE.
               END DO
             ELSE IF (opt_X) THEN         ! mutual exclusion
               keep = srep .EQ. 1
             ELSE                          
               keep = .TRUE.         ! keep unless option to discard
!!               keep = POP(L) > FLOAT(n_file) / 2.
!!               keep = POP(L) .GE. 1.
             END IF  ! options I, R, X ?
             IF (POP(L) < POPMIN) keep = .FALSE.       ! empty clusters are poison
             
*#######################################################################
*                  put center data into event list
*#######################################################################
             IF (keep) THEN
               a = a + 1

               a_t(a) = C(1,L)               ! time
               a_k(a) = k                     ! kind
               h = NINT(C(2,L))
               
!!!!!!!!!!!!!         debug:               
               IF (h < 1 .OR. h > CAT(2)) THEN
                 PRINT*, 'blend: bad channel! trk: ', j, ' kind: ', K,
     $              ' jclust gave: ', h
               END IF
               
               a_c(a) = ctran(h)               ! channel
               a_r(a) = j                       ! track
               a_f(a) = of                       ! new file ID
               a_v(a) = 0                         ! NoteOn may change this
               a_g(a) = -1                         !  "          " 
               
               IF (k .EQ. 1) THEN
                 h = 0
                 DO i = 1, n
                   IF (Z(i) .EQ. L) THEN
                     h = h + 1
                     WORK(h,1) = FLOAT(e_v(g0+i))        ! stash off-velocity
                     WORK(h,2) = FLOAT(e_g(g0+i))        ! stash portamento
                   END IF
                 END DO
                 
                 a_p1(a) = NINT(C(4,L))       ! pitch returned from jclust
                 a_p2(a) = NINT(C(6,L))       ! velocity returned from jclust
                 a_p3(a) = C(7,L)             ! duration returned from jclust
                 IF (opt_O) THEN
                   CALL MEAN (WORK(1,1), h, ave)   ! mean off-velocity
                   a_v(a) = NINT(ave)
                   CALL MEAN (WORK(1,2), h, ave)   ! mean portamento 
                   a_g(a) = NINT(ave)
                 ELSE
                   CALL MEDIAN (WORK(1,1), h, ave)
                   a_v(a) = NINT(ave)
                   CALL MEDIAN (WORK(1,2), h, ave)
                   a_g(a) = NINT(ave)
                 END IF
                 
*                  also create a NoteOff (duroff repeats this ?)
                 a = a + 1
                 a_t(a) = a_t(a-1) + a_p3(a-1)
                 a_k(a) = 0
                 a_c(a) = a_c(a-1)
                 a_p1(a) = a_p1(a-1)
                 a_p2(a) = a_v(a-1)
                 a_p3(a) = 0.
                 a_v(a) = 0
                 a_g(a) = -1
                 a_r(a) = j
                 a_f(a) = of
                 
*                one (continuous) integer datum
               ELSE IF ( (k .GE. 4 .AND. k .LE. 45) .OR. k .EQ. 51 
     $          .OR. k .EQ. 53 .OR. k .EQ. 56 .OR. k .EQ. 57 
     $           .OR. k .EQ. 76 .OR. k .EQ. 77 .OR. k .EQ. 78
     $            .OR. (k .GE. 81 .AND. k .LE. 90) ) THEN
                 a_p1(a) = NINT(C(4,L))

*                one real datum
               ELSE IF (k .EQ. 70 .OR. k .EQ. 71) THEN
                 a_p3(a) = C(4,L)
             
*                categorical datum
               ELSE IF (k .EQ. 3 .OR. k .EQ. 55 .OR. k .EQ. 60  
     $               .OR. k .EQ. 74 .OR. k .EQ. 79 .OR. k .EQ. 80) THEN
                 h = NINT(C(4,L))           ! don't take median, keep mode
                 a_p1(a) = ptran(h)
             
*               kinds with two data
               ELSE IF (k .EQ. 2 .OR. k .EQ. 54 
     $                 .OR. k .EQ. 72) THEN
                 a_p1(a) = NINT(C(4,L))
                 a_p2(a) = NINT(C(5,L))
                 
*                key signature
               ELSE IF (k .EQ. 73) THEN
                 i = NINT(C(4,L))
                 i = MOD(i + 5, 12) - 5          ! restrict to -5 ... +6
                 a_p1(a) = i
                 a_p2(a) = NINT(C(5,L))
                 
*                  NRPN
               ELSE IF (k .EQ. 47) THEN
                 h = NINT(C(4,L))
                 e_p1(a) = ptran(h)
                 e_p2(a) = NINT(C(5,L))
                 
               ELSE IF (k .EQ. 49 .OR. k .EQ. 50 .OR. k .EQ. 52) THEN
                 CONTINUE
                 
               ELSE
                 PRINT *, 'blend: unrecognized event type ?!', K

               END IF
             END IF    ! keep ?
           END DO     ! next cluster       
         END DO     ! next kind 
       END DO      ! next track

       DEALLOCATE (kev, ftran, ptran, Z, kcens, POP, C, RWORK, 
     $   WORK, X, rep, STAT=allerr)
       RETURN
      END        ! of blend


*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
*                 eliminate duplicate blobs
*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
*                             I/O List
*__Name_____________Type__________In/Out__Description___________________
*  BUF[Lb]          INTEGER*1     in      input files
*  Lb               INTEGER       in      length of buffer
*  of               INTEGER       in      ID of the output file
*  mnr              INTEGER       in      number of tracks
*  N                INTEGER       in      number of blobs
*  e_t[e]           REAL          in      event times
*  e_k[e]           INTEGER       in      event kinds
*  e_c[e]           INTEGER       in      event channel
*  e_p1[e]          INTEGER       in      offset into buffer
*  e_p2[e]          INTEGER       in      length of buffer
*  e_f[e]           INTEGER       in      event original file
*  e_r[e]           INTEGER       in      event tracks
*  e                INTEGER       in      length of the event list
*  a_t[e]           REAL          out     blended times
*  a_k[e]           INTEGER       out     blended kinds
*  a_c[e]           INTEGER       out     blended channel
*  a_p1[e]          INTEGER       out     blended data #1
*  a_p2[e]          INTEGER       out     blended data #2
*  a_f[e]           INTEGER       out     new file ID
*  a_r[e]           INTEGER       out     blended tracks
*  a                INTEGER       out     length of blended event list
*
*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
      SUBROUTINE BLELIM (BUF, Lb, of, mnr, n, 
     $  e_t, e_k, e_c, e_p1, e_p2, e_f, e_r, e, 
     $  a_t, a_k, a_c, a_p1, a_p2, a_f, a_r, a)

       IMPLICIT NONE 
       INTEGER Lb, of, mnr, n, e_k, e_c, e_p1, e_p2, e_f, e_r, e, 
     $  a_k, a_c, a_p1, a_p2, a_f, a_r, a
       INTEGER*1 BUF
       REAL e_t, a_t
       DIMENSION  BUF(Lb),
     $  e_t(e), e_k(e), e_c(e), e_p1(e), e_p2(e), e_f(e), e_r(e), 
     $  a_t(e), a_k(e), a_c(e), a_p1(e), a_p2(e), a_f(e), a_r(e)
     
*           local
       INTEGER g, h, i, j, k, kk, L, m,
     $         BKIN(12),                 ! kinds that are blobs
     $         ierr

       LOGICAL same,                      ! strings match
     $         BUFEQ                      ! external function

*            allocatable arrays
       INTEGER, DIMENSION (:), ALLOCATABLE ::
     $         IND,                   ! indices into BUF
     $         IP,                    ! permutation vector
     $         JEV,                   ! event ID of blobs
     $         JFIL,                  ! input file of blobs
     $         LNT                    ! lengths of blobs

       SAVE BKIN
       DATA BKIN / 58, 59, 61, 62, 63, 64, 65, 66, 67, 68, 69, 75 /
       
*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
*                      begin 
*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
       IF (N < 1) RETURN
       ALLOCATE (IND(N), IP(N), JEV(N), JFIL(N), LNT(N), STAT=ierr)
       IF (ierr .NE. 0) THEN
         PRINT *, 'blelim:  trouble allocating memory'
         RETURN
       END IF

       DO kk = 1, 12                ! text-type events
         k = BKIN(kk)

*         remove duplicates blobs on the same track
         DO 70 j = 1, mnr               ! for each track
 
*               find events
           L = 0
           DO i = 1, e
             IF (e_r(i) .EQ. j .AND. e_k(i) .EQ. k) THEN
               L = L + 1
               IND(L) = e_p1(i)
               LNT(L) = e_p2(i)
               JFIL(L) = e_f(i)
               JEV(L) = i
             END IF
           END DO
           IF (L .EQ. 0) GO TO 70
             
*                bring duplicates adjacent
           CALL BUFSRT (BUF, IND, LNT, IP, L)
           CALL IORDER (IND, IP, L)
           CALL IORDER (LNT, IP, L)
           CALL IORDER (JFIL, IP, L)
           CALL IORDER (JEV, IP, L)
         
*            within groups of equal blobs, swap the least file to the front
           g = 1            ! position of least file
           h = 1            ! position of previous distinct entry
           DO i = 2, L
             same = BUFEQ(BUF, IND(h), IND(i), LNT(h), LNT(i))
             IF (same .AND. JFIL(i) < JFIL(g)) g = i
             IF (.NOT. same .OR. i .EQ. L) THEN
               IF (g .NE. h) THEN
                 m = IND(g) ; IND(g) = IND(h) ; IND(h) = m
                 m = LNT(g) ; LNT(g) = LNT(h) ; LNT(h) = m
                 m = JFIL(g) ; JFIL(g) = JFIL(h) ; JFIL(h) = m
                 m = JEV(g) ; JEV(G) = JEV(H) ; JEV(H) = m
               END IF
               g = i
               h = i
             END IF
           END DO
            
*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
*             compare adjacent strings
*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
           h = 1               ! JFIL(h) .EQ. JFIL(i) on first iteration
           DO i = 1, L 
             same = BUFEQ (BUF, IND(h), IND(i), LNT(H), LNT(I))
             
*               Leave equal strings from the same first source file intact.
*               Presumably the composer had a reason for the repeat.
             IF ( (.NOT. same) .OR. (JFIL(h) .EQ. JFIL(i)) ) THEN
               a = a + 1                     ! make event
               a_t(a) = e_t(JEV(i))
               a_k(a) = k
               a_c(a) = e_c(JEV(i))
               a_p1(a) = IND(i)
               a_p2(a) = LNT(i)
               a_f(a) = of
               a_r(a) = j
               h = i
             END IF
           END DO  ! next event
  70     END DO  ! next track
       END DO  ! next kind

       DEALLOCATE (IND, IP, JEV, JFIL, LNT, STAT=ierr)
       IF (ierr .NE. 0) THEN
         PRINT *, 'blelim:  trouble releasing memory'
         RETURN
       END IF
       RETURN
      END ! of BLELIM
      
*-----------------------------------------------------------------------
* fitfn - convert logarithm of probability to fitness
*-----------------------------------------------------------------------
      FUNCTION FITFN (P)
       IMPLICIT NONE
       REAL P, FITFN
       INTEGER N ; PARAMETER (N = 7)
       FITFN = (-1. / P) **N           ! to the Nth degree
       RETURN
      END  ! of FITFN


*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
* gene - a genetic algorithm for MIDI data
* by Andy Allinger, 2016, released to the public domain.
* This program may be used by any person for any purpose.
*
* Steady-state, elitist, trisexual, roulette selection, incest taboo.
* Uses data clustering to cross over organisms of different lengths.
*
*                             I/O List
*_Name______________Type______________I/O____Description________________
* e_t[etot]         Real              in     times of events
* e_k[etot]         Integer           in     event kinds
* e_c[etot]         Integer           in     event channels (unused?)
* e_p1[etot]        Integer           in     event data part 1
* e_p2[etot]        Integer           in     event data part 2
* e_p3[etot]        Real              in     event data (duration or tempo)
* e_v[etot]         Integer           in     note-off velocities
* e_g[etot]         Integer           in     portamento prefixes
* e_f[etot]         Integer           in     event source file 
* e_r[etot]         Integer           in     event track
* e_u[etot]         Real              out    event metrical times (in tactus)
* ind[etot]         Integer           work   permutation vector
* etot              Integer           in     length of event list
* fit_e[n_file]     Real              in     fitness of elite organisms
* n_gen             Integer           in     # iterations
* n_file            Integer           in     # of input files
* aid               Integer           both   ID of blended file
* opt_E             Logical           in     expensive
* opt_H             Logical           in     hyperplane initialization
* opt_O             Logical           in     not robust
* rid[n_file]       Logical           none   (all false)
* yield             Real              in     yield rate
* mnr               Integer           in     maximum number of tracks
* kul               Integer           in     most events of any kind, any track
* uprofile[0:11, 0:1] Real            in     frequency of pitches
* ms                Double Precision  in     sum of pitch difference
* ms2               Double Precision  in     sum of square pitch difference
* pkarr[0:127,0:127,0:11,0:1]   Real  in     probability matrix of prox & key
* rpar[8]           Real              in     rhythm detection parameters
* rsum[9]           Double Precision  in     statistic totals for setting rpar
* uprox[0:6]        Real              in     custom chord proximity
* uqual[num_q,0:1]  Real              in     custom chord quality 
* uroot[0:11,0:1]   Real              in     custom chord root data
* ccarr[num_q,0:11,0:11,0:1] Real     in     frequency of chords given a chord
* nsteps            Integer           work   how many rhythm time points
* npts              Integer           work   # spline interpolation points
* step              Real              in     duration of oscillator evaluation
* drum[0:15]        Logical           in     indicates drum channel(s)
* ttmp[nsteps+1]    Real              none   onset time of a tempo change
* thz[nsteps+1]     Real              none   frequency of a tempo change
* nt                Integer           none   number of tempo changes
* avgtem            Real              none   average tempo
* key_t[keylim]     Real              none   times of key changes
* sharps[keylim]    Integer           none   sharps in key signature
* majmin[keylim]    Integer           none   major or minor key
* keylim            Integer           none   array bound of key_t, sharps,
* nk                Integer           none   number of detected key changes
* psi[0:127,0:15]   Integer           work   pointer to sound inception
* a_t[olim]         Real              out    output times
* a_k[olim]         Integer           out    output kinds
* a_c[olim]         Integer           out    output channel
* a_p1[olim]        Integer           out    output data #1
* a_p2[olim]        Integer           out    output data #2
* a_p3[olim]        Real              out    output data #3
* a_v[olim]         Integer           out    output off-velocity
* a_g[olim]         Integer           out    output portamento prefix
* a_f[olim]         Integer           out    new file ID
* a_r[olim]         Integer           out    output tracks
* a_u[olim]         Real              work   output metrical time
* L_a               Integer           both   length of output event list
* olim              Integer           in     max possible length of output
* fit_a             Real              both   fitness of alpha organism
* ierr              Integer           out    error code
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
      SUBROUTINE GENE (e_t, e_k, e_c, e_p1, e_p2, e_p3, e_v, e_g, e_f,
     $  e_r, e_u, ind, etot, fit_e, n_gen, n_file, aid, opt_E, opt_H, 
     $  opt_O, rid, yield, mnr, kul, uprofile, ms, ms2, pkarr, rpar, 
     $  rsum, uprox, uqual, uroot, ccarr, nsteps, npts, step, 
     $  drum, ttmp, thz, nt, avgtem, key_t, sharps, majmin, keylim,
     $  nk, psi, a_t, a_k, a_c, a_p1, a_p2, a_p3, a_v, a_g, a_f, a_r, 
     $  a_u, L_a, olim, fit_a, ierr)

       IMPLICIT NONE
       INTEGER num_q ; PARAMETER (num_q = 15)    ! make sure this matches 
       INTEGER e_k, e_c, e_p1, e_p2, e_v, e_g, e_f, e_r, ind, etot,
     $  n_gen, n_file, aid, mnr, kul, nsteps, npts, nt, sharps, 
     $  majmin, keylim, nk, psi, a_k, a_c, a_p1, a_p2, a_v, a_g, a_f,
     $  a_r, L_a, olim, ierr
       REAL e_t, e_p3, e_u, fit_e, yield, uprofile, pkarr, rpar,
     $  uprox, uqual, uroot, ccarr, step, ttmp, thz, avgtem,
     $  key_t, a_t, a_p3, a_u, fit_a
       DOUBLE PRECISION ms, ms2, rsum
       LOGICAL opt_E, opt_H, opt_O, rid, drum 
       DIMENSION 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), fit_e(n_file), rid(n_file),
     $  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), ttmp(nsteps+1),
     $  thz(nsteps+1), key_t(keylim), sharps(keylim), majmin(keylim),
     $  psi(0:127,0:15), a_t(olim), a_k(olim), a_c(olim), a_p1(olim),
     $  a_p2(olim), a_p3(olim), a_v(olim), a_g(olim), a_f(olim), 
     $  a_r(olim), a_u(olim)
     
*              constants
       INTEGER MINSTP, n_pop, n_sex, maxdra, N_KIND
       REAL defp
       LOGICAL rsrch
       PARAMETER (
     $            DEFP = -9999.,     ! value for when analysis fails
     $            MAXDRA = 99,       ! don't get stuck in loop
     $            MINSTP = 7,        ! shortest input to spline interpolator
     $            N_KIND = 90,       ! match main program, midifile.f
     $            n_pop = 100,       ! default in PGAPACK
     $            n_sex = 3,         ! so that median is taken of odd # objects
     $            rsrch = .FALSE. )  ! polyph replaces ANALYZ

*              locals
       INTEGER 
     $         aped(n_sex),           ! pedigree of alpha
     $         CEIL,                  ! external function CEILING
     $         i, ii, j, k,           ! counters
     $         icull,                 ! index of entity being replaced
     $         ilim,                  ! array bound of i_
     $         iped(n_sex,n_sex),     ! pedigrees of files sent to BLEND
     $         isel,                  ! index selected
     $         iu,                    ! offset into U
     $         L_u(n_pop),            ! length of U_ arrays
     $         Lw,                    ! entries on roulette wheel
     $         lastid,                ! file ID to assign next
     $         newped(n_sex),         ! new pedigree
     $         ndraw,                 ! number of retries of selection
     $         n_org,                 ! number of underling organisms present
     $         no,                    ! # of note-ons
     $         uid(n_pop),            ! file ID of underlings
     $         uped(n_sex,n_pop)      ! pedigrees of underling
     
       REAL  fit_u(n_pop),            ! fitness of common organisms
     $       p,                       ! log-probability from ANALYZ
     $       r,                       ! temp scalar
     $       tend,                    ! time of final event
     $       wtot                     ! last entry in WHEEL
     
       LOGICAL allsam                 ! all parents are identical
       
*           external functions
       REAL FITFN
       LOGICAL ALMEQ 
      
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
*              allocatable arrays
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
       INTEGER, DIMENSION (:), ALLOCATABLE ::
     $     iind,               ! work array for blend
     $     i_k,                ! input to BLEND, kinds
     $     i_c,
     $     i_p1,
     $     i_p2,
     $     i_v,
     $     i_g,
     $     i_r,
     $     i_f, 
     $     JSW                ! work array for sorting

       INTEGER, DIMENSION (:,:), ALLOCATABLE ::
     $     u_k,                       ! underling kinds
     $     u_c,                       ! underling channel
     $     u_p1,                      ! underling data
     $     u_p2,                      !  "        "
     $     u_v,                       ! underling off-velocity
     $     u_g,                       ! underling gliss
     $     u_r,                       ! underling track
     $     u_f                        ! underling file ID
     
       REAL, DIMENSION (:), ALLOCATABLE ::
     $        i_t,
     $        i_p3,
     $        i_u,
     $        posfit,                 ! fitness as a positive qty.
     $        RSW,                    ! workspace for sorting
     $        wheel                   ! roulette wheel
     
       REAL, DIMENSION (:,:), ALLOCATABLE ::
     $     u_t,                       ! underling times
     $     u_p3,
     $     u_u
     
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
*               begin
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
       ierr = 0
       ilim = n_sex * olim
       Lw = 1 + n_file + n_pop                ! size to allocate
       IF (n_file + 1 .NE. aid)
     $   PRINT *, 'gene:  n_file = ', n_file, ' but aid = ', aid, ' !'
       lastid = aid
       DO i = 1, n_sex
         aped(i) = aid
       END DO
       n_org = 0
       
        PRINT *, 'in gene: ilim: ', ILIM, ' olim: ', OLIM, 
     &               ' etot: ', ETOT, ' L_a: ', L_a

       ALLOCATE (iind(ilim), i_t(ilim), i_k(ilim),  
     $  i_c(ilim), i_p1(ilim),
     $  i_p2(ilim), i_p3(ilim), i_v(ilim), 
     $  i_g(ilim), i_r(ilim), i_f(ilim), JSW(3*ilim),
     $  i_u(ilim), u_t(olim,n_pop), RSW(3*ilim), u_k(olim,n_pop), 
     $  u_c(olim,n_pop), u_p1(olim,n_pop), u_p2(olim,n_pop), 
     $  u_p3(olim,n_pop), u_v(olim,n_pop), u_g(olim,n_pop), 
     $  u_r(olim,n_pop), u_f(olim,n_pop), u_u(olim,n_pop), 
     $  posfit(Lw), wheel(Lw), STAT=ierr)

       IF (ierr .NE. 0) THEN
         PRINT *, 'gene: trouble allocating!'
         RETURN
       END IF
       
*                 check that fitness values are negative (ie - log probability)
       DO i = 1, n_file
         PRINT *, 'gene: fitness of org ', i, ' is ', fit_e(i)
         IF (fit_e(i) .GE. 0.) THEN
           PRINT *, 'gene:  positive log probability at fit_e[', i,']'
           ierr = 1
           RETURN
         END IF
       END DO
       PRINT *, 'gene: fitness of org a is ', fit_a
       IF (fit_a .GE. 0.) THEN
         PRINT *, 'gene: positive log probability!'
         IERR = 1
         RETURN
       END IF

*         set posfit
       DO i = 1, n_file
         posfit(i) = FITFN(fit_e(i))
       END DO  ! next i
       posfit(n_file+1) = FITFN(fit_a)
       
!!!!!!!!!!!!!!!!!!!!! NaN check
       DO i = 1, n_file+1
         IF (ISNAN(posfit(i))) PRINT *,'gene: NaN in posfit at ', i
       END DO       

*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
*              main loop
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
       DO k = 1, n_gen
         
!!         PRINT *, 'gene: beginning iteration ', K
       
*            population array full ?
         IF (n_org .EQ. n_pop) THEN  ! cull probability proportional to entropy

!           wheel(1) = -fit_u(1)
!           DO j = 2, n_org
!             wheel(j) = wheel(j-1) - fit_u(j)
!           END DO
!!!!!!!!!!!!!!!!!!!! sharpen selection with higher power fitness
           wheel(1) = -fit_u(1) **7
           DO j = 2, n_org
             wheel(j) = wheel(j-1) - fit_u(j) **7
           END DO

           wtot = wheel(n_org)
           IF (ALMEQ(wtot, 0.)) THEN
             PRINT *, 'gene:  division by zero ??!!'
             ierr = 1
             RETURN
           END IF
           wtot = 1. / wtot
           DO j = 1, n_org
             wheel(j) = wheel(j) * wtot
           END DO
           
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
*             draw index to cull
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
           r = RAND(0)
           CALL RBSGT (wheel, n_org, r, icull)
           
*             new organism added to end of list
         ELSE
           icull = n_org + 1      ! don't increment n_org yet
         END IF  ! population at capacity ?  
                      
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
*             cumulative fitness - inverse to entropy
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
         IF (n_org .EQ. n_pop) THEN   ! turn of elitism in later generations
           DO j = 1, n_file
             posfit(j) = 0.
           END DO
         END IF
         wheel(1) = posfit(1)
         Lw = n_file + 1 + n_org
         DO j = 2, Lw
           wheel(j) = wheel(j-1) + posfit(j)
         END DO
         wtot = wheel(Lw)
         IF (ALMEQ(wtot, 0.)) THEN
           PRINT *, 'gene:  division by zero ??!!'
           ierr = 1
           RETURN
         END IF
         wtot = 1. / wtot
         DO j = 1, Lw
           wheel(j) = wheel(j) * wtot
!           PRINT *, 'gen ', K, ' wheel[', J, '] is ', WHEEL(J)
         END DO
        
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
*            Pick ancestors
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
         ndraw = 0
  10     CONTINUE             
         ii = 0                    ! index into i_
         DO j = 1, n_sex
           r = RAND(0)
           CALL RBSGT (wheel, Lw, r, isel)      ! search
!           PRINT *, 'spun wheel, selected organism ', ISEL

*                 select e_
           IF (isel .GE. 1 .AND. isel .LE. n_file) THEN

!!!!!!!!!!!!!!!!!!!!!!!! TAMPER: turn of elitism
!!!!!!!!!!!!!!             IF (n_org .EQ. n_pop) GO TO 10
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

             DO i = 1, etot
               IF ( isel .EQ. e_f(i) .AND. 
     $               (e_k(i) .GE. 0) .AND. (e_k(i) < N_KIND) ) THEN
                 ii = ii + 1
                 i_t(ii) = e_t(i)
                 i_k(ii) = e_k(i)
                 i_c(ii) = e_c(i)
                 i_p1(ii) = e_p1(i)
                 i_p2(ii) = e_p2(i)
                 i_p3(ii) = e_p3(i)
                 i_v(ii) = e_v(i)
                 i_g(ii) = e_g(i)
                 i_r(ii) = e_r(i)
!                 i_f(ii) = e_f(i)
                 I_F(II) = J               ! require small consecutive integers
                 i_u(ii) = e_u(i)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!       PRINT *, ii, 'th event is: ', e_t(ii), e_k(ii), e_c(ii), 
!     &  e_p1(ii), e_p2(ii), e_p3(ii), e_v(ii), e_g(ii), i_r(ii), 
!     &  i_f(ii), ' j:', j, i_u(ii)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!                 

               END IF
             END DO
             DO i = 1, n_sex
               iped(i,j) = isel
             END DO
             newped(j) = isel

*                 select a_
           ELSE IF (isel .EQ. n_file+1) THEN
             DO i = 1, L_a
               ii = ii + 1
               i_t(ii) = a_t(i)
               i_k(ii) = a_k(i)
               i_c(ii) = a_c(i)
               i_p1(ii) = a_p1(i)
               i_p2(ii) = a_p2(i)
               i_p3(ii) = a_p3(i)
               i_v(ii) = a_v(i)
               i_g(ii) = a_g(i)
               i_r(ii) = a_r(i)
!               i_f(ii) = aid
               I_F(II) = J
               i_u(ii) = a_u(i)
             END DO
             DO i = 1, n_sex
               iped(i,j) = aid
             END DO
             newped(j) = aid
                          
*              select u_
           ELSE IF (isel > n_file+1 .AND. isel .LE. Lw) THEN
             iu = isel - n_file - 1
             DO i = 1, L_u(iu)
               ii = ii + 1
               i_t(ii) = u_t(i,iu)
               i_k(ii) = u_k(i,iu)
               i_c(ii) = u_c(i,iu)
               i_p1(ii) = u_p1(i,iu)
               i_p2(ii) = u_p2(i,iu)
               i_p3(ii) = u_p3(i,iu)
               i_v(ii) = u_v(i,iu)
               i_g(ii) = u_g(i,iu)
               i_r(ii) = u_r(i,iu)
!               i_f(ii) = u_f(i,iu)
               I_F(II) = J
               i_u(ii) = u_u(i,iu)
             END DO
             DO i = 1, n_sex
               iped(i,j) = uped(i,iu)
             END DO
             newped(j) = uid(iu)
           
           ELSE
             PRINT *, 'gene:  bad index selected'
           END IF
         END DO  ! next j
         
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
*              prevent incest in later generations
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
         IF (n_org .EQ. n_pop) THEN
           CALL NUNIQ (iped, n_sex*n_sex, j)      ! # distinct individuals
!           PRINT *, 'nuniq returns:  ', J, ' distinct grandparents'
           IF (j < n_sex * n_sex - n_sex .AND. ndraw < MAXDRA) THEN
             ndraw = ndraw + 1
             GO TO 10  ! and pick again
           END IF
         END IF
         
         allsam = .TRUE.                   ! prevent self-fertilization
         DO i = 2, n_sex
           IF (newped(i-1) .NE. newped(i)) allsam = .FALSE.
         END DO
         IF (allsam .AND. n_file > 1 .AND. ndraw < MAXDRA) THEN
           ndraw = ndraw + 1
           GO TO 10
         END IF
         IF (ndraw .EQ. MAXDRA) PRINT *, 'gene: no diversity!'
           
         DO i = 1, n_sex                            ! keep track of ancestry
           uped(i,icull) = newped(i)
         END DO
         lastid = lastid + 1
         uid(icull) = lastid
         IF (n_org < n_pop) n_org = n_org + 1
     
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
*                 Breed.
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
      
!!!!!!!!!!!!!!!!! debug dump
!        PRINT *, 'gene: call blend with n_sex: ', N_SEX, ' lastid: ', 
!     &   lastid, ' opt_E: ', OPT_E, ' mnr: ', MNR, ' kul: ', KUL,
!     &   ' ii: ', II
!        PRINT *, 'input array: t k c p1 p2 p3 v g f r u'
!        DO i = 1, ii
!          PRINT *, i_t(i), i_k(i), i_c(i), i_p1(i), i_p2(i), i_p3(i),
!     &        i_v(i), i_g(i), i_f(i), i_r(i), i_u(i)
!        END DO
!!!!!!!!!!!!!!!!!!!!!!!!

         CALL BLEND (n_sex, lastid, opt_E, .TRUE., opt_H, .FALSE., 
     $    .TRUE., opt_O, .FALSE., .FALSE., .FALSE., rid, yield, mnr, 
     $    kul, i_t, i_k, i_c, i_p1, i_p2, i_p3, i_v, i_g, i_f, i_r, i_u,
     $    iind, RSW, JSW, ii, u_t(1,icull), u_k(1,icull), u_c(1,icull), 
     $    u_p1(1,icull), u_p2(1,icull), u_p3(1,icull), u_v(1,icull), 
     $    u_g(1,icull), u_f(1,icull), u_r(1,icull), L_u(icull), i)
 
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
*                Mutate.
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 
!!         r = RAND(0) **2      ! p = 1/pop is recommended but that's tiny
         r = RAND(0)
         IF (r < 1. / FLOAT(n_pop))                 ! small probability
     $     CALL JITTER (u_t(1,icull), u_k(1,icull), u_p1(1,icull), 
     $      u_p2(1,icull), u_p3(1,icull), L_u(icull))
         

*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 
*               Correct Note-Offs
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 
         CALL DUROFF (u_t(1,icull), u_k(1,icull), u_c(1,icull), 
     $    u_p1(1,icull), u_p2(1,icull), u_p3(1,icull), u_v(1,icull),
     $    u_g(1,icull), u_f(1,icull), u_r(1,icull), ind, RSW, JSW, 
     $    L_u(icull), psi)
     
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
*           Measure fitness
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
         tend = 0. ; no = 0
         DO i = 1, L_u(icull)
           tend = MAX(tend, u_t(i,icull))
           IF (u_k(i,icull) .EQ. 1) no = no + 1
         END DO 
         IF (rsrch) THEN
           CALL POLYPHI (drum, u_t(1,icull), u_k(1,icull), u_c(1,icull),
     $      u_p1(1,icull), u_p2(1,icull), u_p3(1,icull), u_v(1,icull),
     $      u_g(1,icull), u_f(1,icull), u_r(1,icull), u_u(1,icull),
     $      ind, RSW, JSW, L_u(icull), .FALSE., p, ierr)
           IF (ierr .NE. 0) PRINT *, 'gene: polyphi returns #', IERR
           IF (ISNAN(p)) PRINT *, 'gene: polyph returns NaN fitness!!'
         END IF
         IF (.NOT. rsrch 
     $        .OR. ierr .NE. 0           ! polyph failed ?
     $         .OR. p .NE. p 
     $          .OR. ALMEQ(p,0.)) THEN
           nsteps = CEIL(tend / step) 
           npts = (nsteps - 1) / 2 + 1
           IF (nsteps < MINSTP) npts= 1
           CALL ANALYZ (uprofile, ms, ms2, pkarr, rpar, rsum, uprox,
     $      uqual, uroot, ccarr, no, nsteps, npts, step, tend, .TRUE.,
     $      .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., 
     $      .FALSE., .FALSE., .FALSE., .FALSE., drum, u_t(1,icull),
     $      u_k(1,icull), u_c(1,icull), u_p1(1,icull), u_p2(1,icull),
     $      u_p3(1,icull), u_v(1,icull), u_g(1,icull), u_f(1,icull),
     $      u_r(1,icull), u_u(1,icull), ind, RSW, JSW, L_u(icull), ttmp,
     $      thz, nt, avgtem, key_t, sharps, majmin, keylim, nk, p, psi)
         END IF
         
         IF (ISNAN(p)) THEN
           PRINT *, 'gene:  analyze returns NaN fitness!!'
           p = defp
         END IF
         IF (p .GE. 0.) THEN
           PRINT *, 'gene:  analyze returns nonnegative log-prob!'
           ierr = 2
           RETURN
         END IF
         p = p / FLOAT(no)             ! adjust for length of file
         fit_u(icull) = p
         posfit(n_file+1+icull) = FITFN(p)

         PRINT *, 'gene: iter ', k, ' Parents: ', newped, ' Fitness: ',
     $     posfit(n_file+1+icull), ' events: ', L_u(icull)

*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
*               Compare fitness
*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@       
         IF (p > fit_a) THEN              ! new alpha tune
           r = p ; p = fit_a ; fit_a = r          ! swap fitness
           DO i = 1, n_sex                          ! swap pedigree
             j = uped(i,icull) ; uped(i,icull) = aped(i) ; aped(i) = j
           END DO
           j = uid(icull) ; uid(icull) = aid ; aid = j            ! swap ID
           DO i = 1, MAX(L_a, L_u(icull))          ! swap events
             r = u_t(i,icull) ; u_t(i,icull) = a_t(i) ; a_t(i) = r
             j = u_k(i,icull) ; u_k(i,icull) = a_k(i) ; a_k(i) = j
             j = u_c(i,icull) ; u_c(i,icull) = a_c(i) ; a_c(i) = j
             j = u_p1(i,icull) ; u_p1(i,icull) = a_p1(i) ; a_p1(i) = j
             j = u_p2(i,icull) ; u_p2(i,icull) = a_p2(i) ; a_p2(i) = j
             r = u_p3(i,icull) ; u_p3(i,icull) = a_p3(i) ; a_p3(i) = r
             j = u_v(i,icull) ; u_v(i,icull) = a_v(i) ; a_v(i) = j
             j = u_g(i,icull) ; u_g(i,icull) = a_g(i) ; a_g(i) = j
             j = u_f(i,icull) ; u_f(i,icull) = a_f(i) ; a_f(i) = j
             j = u_r(i,icull) ; u_r(i,icull) = a_r(i) ; a_r(i) = j
             r = u_u(i,icull) ; u_u(i,icull) = a_u(i) ; a_u(i) = r
           END DO
           j = L_u(icull) ; L_u(icull) = L_a ; L_a = j      ! swap lengths
           PRINT *, 'new alfa organism. pedigree: ', aped, 
     $                 ' fitness: ', fit_a
         END IF

       END DO  ! next k
       
       PRINT *, 'gene: complete.  alfa pedigree: ', aped
       DEALLOCATE (iind, i_t, i_k, i_c, i_p1,i_p2, i_p3, i_v, i_g, i_r, 
     $  i_f, i_u, u_t, u_k, u_c, u_p1, u_p2, u_p3, u_v, u_g, u_r, u_f, 
     $  u_u, posfit, wheel, STAT=ierr)
       IF (ierr .NE. 0) PRINT *, 'gene: trouble deallocating!'
       
       RETURN
      END  ! of GENE
