************************************************************************ * 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] [input2.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