diff options
Diffstat (limited to 'Build/source/utils/pmx/pmx-2.6.21/pmx2619.for.orig')
-rw-r--r-- | Build/source/utils/pmx/pmx-2.6.21/pmx2619.for.orig | 23678 |
1 files changed, 23678 insertions, 0 deletions
diff --git a/Build/source/utils/pmx/pmx-2.6.21/pmx2619.for.orig b/Build/source/utils/pmx/pmx-2.6.21/pmx2619.for.orig new file mode 100644 index 00000000000..3dd1b201a92 --- /dev/null +++ b/Build/source/utils/pmx/pmx-2.6.21/pmx2619.for.orig @@ -0,0 +1,23678 @@ + program pmxab +c +c This program, PMX, developed by Don Simons +c (dsimons@roadrunner.com), is a preprocessor for MusiXTeX. In concert with +c MusiXTeX and TeX, its purpose is to allow the user to create high-quality +c typeset musical scores by including a sequence of PMX commands in an ASCII +c input file. +c +c This program is free software: you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation, either version 3 of the License, or +c (at your option) any later version. +c +c This program is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with this program. If not, see <http://www.gnu.org/licenses/>. +c +c + character*9 date + character*5 version,versionc + common /comver/ versionc +c +c To compile with gfortran: +c 1. Merge all files using copy *.for epmx[nnnn].for +c 2. Search and replace all character*65536 with character*131072 +c 3. Comment/uncomment getarg lines +c 4. gfortran -O pmx[nnnn].for -o pmxab.exe +c +c To do +c Correct Rainer's email address in manual +c Linesplit (\\) in h +c Tt at start of a movement. +c Toggle midi on or off; allow midi only. +c Page number printed on 1st page even if 1 system. +c Still need inserted space for chordal accidentals +c Voicewise transposition. +c better segno +c coda +c duevolte +c Fix xtup bracket direction in 2-line staves?? (maybe leave as is) +c Sticky ornaments with shifts. +c Deal with Werner's vertical spacing thing associated with title. +c Multiple ties in midi +c Werner's missing c in MIDI due to start/stop ties on same note. +c Beams with single 64ths +c 128ths and/or dotted 64ths +c Close out MIDI with integral # of beats? +c Increase ast dimensions or redo logic. +c Does slur direction get set for user-defined single-note stem dir'ns? +c Transpose by sections. +c Optimization loop over sections only +c Command-line option to read nbarss in. Write out nbarss when optimizing. +c (or just read from .plg?) +c Beams over bar lines. +c 2-digit figures +c A real coule (slanted line between notes in a chord) +c Dotted slurs for grace notes. +c Undotted chord notes with dotted main note. +c Forced line break without line number +c Fix dot moving when 2nds in chord get flipped +c To do: increase length on notexq in dodyn +c 2.619 +c At movement break, change \nbinstruments in \newmovement macro; add +c 3rd arg to \newmovement in pmx.tex; modify pmxb.for and getnote.for +c to remove call to newnoi and change call to \newmovement +c 2.618 +c Add option Ac[l,4] to set vert and horiz size and offsets to properly +c center page for letter or a4 paper. +c 2.617 +c In g1etnote, change if-check for note to use index(...) instead +c of ichar(charq) since it was messing up gfortran optimizer +c After pmxa, search for and remove penultimate line <blank><blank>/ +c because it was screwing up linux-compiled versions +c Bugfix: Increase dimension of kicrd from 7 to 10 in crdaccs(...) +c 2.616 (111110) +c Allow hairpins to span multiple notes groups (gulps). +c 2.615+ (110810) +c Fix midi when some instruments are transposed, by subtracting +c iTransAmt(instno(iv)) from pitch values sent to via addmidi in +c make2bar.for (for main notes) and docrd (for chord notes) +c 2.615 (110725) +c Fig bug with size-setting (in topfile) when instrument has >1 staves +c 2.615 (110724) +c Make AS[0|-|s|t]... really set sizes +c 2.614 +c Mod notex.for to fix Terry's bug with raised dotted rests (caused +c by double-hboxing). +c 2.613 +c Bugfix: In pmxa, change "do while" limit to keep from overwriting instno. +c 2.612 +c Enhance AS to allow s or t for smallsize or tinysize +c 2.611 +c Error trap for "D" before any notes in a block. +c 2.610 +c Instrument-wise key changes and transposition (incomplete) +c 2.603 +c 101211 In getpmxmod.for, decreased nline by 2 to fix locating errors +c following reading in an include file. +c 101121 Added some error messages in g1etset.for setup data +c 2.602 +c Correct slur indexing in linebreakslurs. +c Account for comment lines in line count for error messages +c 2.601 +c Bug fix: allow 24 slurs with graces +c 2.60 Changes made make it really big +c increase mv (size of midi) ? Note: MIDI can't have >16 voices w/o +c major reprogramming, and 16 may also be a problem (icmm) +c nm=24 (voices) done +c 24 slurs done +c 24 simultaneous beams (Replace index 24 by 0, so get 0-23) +c bufq*131072 (gfortran only) +c getarg syntax (gfortran only) +c 2.523+ +c Fix voice numbering for normal dynamics and text dynamics +c 2.523 +c Version of bigpmx first posted to Hiroaki's web site. +c 2.522 +c 5/26/10 Replace ipl bits 0-7 with ipl2, add new common for it. +c With 2.521+ as starting version, incorporate bigpmx mods to allow 24 voices. +c 5/13/10 Fix log2 function +c 5/15/10 Fix bitwise storage for dynamics, fix segnoo string length. +c 2.521+ +c 091025 Enable dotting 2nd part of linebreak slur or tie. +c To adjust barno height due to linebreak slur, use \bnrs instead of +c explicitly redefining \raisebarno (pmxb) +c 2.521 +c Bugfix +c 2.520 +c 090519 Enable ligfonts (special figured bass characters) +c 2.519 +c Fix another bug which kept \sk from being output so misaligned some notes. +c 2.518 +c Fix bugs: referencing fig data, char declaration for member of +c common/comfig/ +c 2.517 +c Allow figures in voice 1 + any one other. +c 2.516 +c Allow figures in voice #2 +c 2.515+ to do: Change manual and activate rule against clef change in voice #2. +c 2.515 +c 071222 Changes in getnote to allow auto forced beams to start anywhere. +c 071206 In make2bar, shift fermataup7 to left over centered pause. +c 070901 In doslur, check for nolev <=2 in case slur ends on rest in 2-line +c staff (it was screwing up vertical justification). +c n34 for tweaks to midi durations of quarter note septuplets. +c To do: In ref250.tex, the tables where 's,t,)' is explained, the line +c [+,- i] ... Vertical adjustment of the start of second segment +c should it be replaced by +c [s +,- i] ... Vertical adjustment of the start of second segment +c 2.514 +c Changes in make2bar to get horizontal spacing right when normal grace +c follows after grace +c Changes in dograce to get octaves right for any material entered inside +c \gaft, which shields transpose register changes from the outside world. +c 2.513 +c In make1bar, near end, for forced beams starting with a rest, copy hgt and +c slope tweaks to ALL notes after first, not just the second one, so if +c there's more than one rest at start the tweaks are still observed. +c In beamid and beamend, add stand-alone triply-flagged notes for xtups. +c 2.512 +c Near end of pmxb, fix error trap to allow redundant 'RD' +c Enable multiplicity down-up '][' within xtup. +c 2.511 +c Introduce eskz2 for xtup #'s and bracket lengths, to remove bug caused by +c adjusteskz as in bar 7 of barsant. +c 2.510a +c Test: remove restriction on tempo changes in MIDI macros +c Send to CM for beta testing. +c 2.509+ +c To do: Correct manual on AS. "-" is for smaller staves. +c 2.510 +c Forgot to declare litq, voltxtq as character in subroutine getgrace +c 2.509 +c Corrected small bug in arpeggio shifting (ivx <= iv in call putarp) +c 2.508 +c Allow graces in xtups. New subroutine getgrace. +c 2.507 +c To do: Raise/lower figures. +c To do: Add 24, 29 to list of musicsizes in manual +c New sub adjusteskz to account for ask's when computing lengths of +c brackets for unbeamed xtups, slopes and horizontal posn's of number +c Bug fix: in beamn1, beamid, and beamend, allow unbeamed xtups w/ 2 flags +c Add look-left option for keyboard rests, "L" in rest command, set iornq(30) +c 2.506 +c Fix bug with AK, when simultaneous rests have same duration, use defaults. +c 2.505 +c Keyboard rests AK +c 2.504 +c Space after normal grace: option X[n] +c Fixed og when nv .ne. noinst, by using sepsymq instead of '&' +c (To do) length of xtup bracket when there is added non-collision space. +c Trap musicsize if .ne. 16,20,24,29. +c 2.503 +c Enable arpeggio left shift with ?-x +c To do: In manual, arpeggio over 2 staves. +c Allow musicsize of 24 and 29. Had to define meter font size explicitly, +c also change font size for text dynamics, but not much else so far. +c Bugfix in beamstrt, introduced in 2415, ip was changed before putxtn +c was called, causing error in printing replacement number. +c 2.502 +c Incorporate Dirk Laurie's patch to use { , } , for ties. +c Figure height adjustment: append +[n] +c Change ec font stuff in pmx.tex per Olivier Vogel's comment (CM email?) +c 2.501 +c Readjust horizontal offset back to .8 in LineBreakTies +c Fix zero-subscript (iudorn) in putorn +c 2.50 +c Increase number of text-dynamics (dimension of txtdynq) per block +c from 12 to 41. +c Slur option n to override altered default curvature. +c Allow default ps slur curvature tweaks with Ap+/-c +c 2.416 +c Increase length of textdynq from 24 to 128 +c (Todo) Add comment in manual about blank lines at end. +c Configuration file: Define subroutine getpmxmod, check path in environment +c variable pmxmoddir, check existence, read lines into bufq after setup. +c Increase dimension on idynn in dodyn from 4 to 10 for max number +c of marks in a bar +c Increase allowable # of lines from 2000 to 4000. +c (To do) Replace definition of \liftpausc per Olivier. +c (To do) Fix extraneous error message if RD is placed at very end. +c 2.415 +c Fix "AT" option: replace putxtn,topfile,beamstrt,beamid to use \xnumt +c instead of redefining \xnum. Change font used to \smallfont (as for +c normal xtups, +c Allow slur to start on rest. +c 2.414 +c Correct bug in crdacc when adding accidental to boundary causes number of +c segments to decrease +c Special rule for 3-accidental chords: If no 2nds, place them in order +c top, bottom, middle. +c 2.413 +c Correct bugs in chordal accidentals, related to left-shifted noteheads +c (a) Special problems with downstem when main note needs shifting +c (b) Assign 0 rank to boundary segs due to left-shifted noteheads +c 2.412 +c Change default horiz shift of start of seg 2 of linebreak slurs: +c -.7 for slurs, -1.2 for ties, +c Use height of start of seg 1 slur itself for end of 1 and start of 2. +c 2.411 +c "Apl" activates special treatment of linebreak slur/tie's; breaks all in 2. +c "s" option in start of slur/tie as precursor to vert/horiz tweaks for end +c of seg 1. of linebreak slur/tie, 2nd "s" for start of seg2. +c With "Apl", curvature adjustments on starting slur command apply to seg 1, +c those on ending command to seg 2. +c 2.410 +c "AT" to allow Col. S.'s tuplet option. Simply input tuplet.tex and redefine +c \xnum, \unbkt, \ovbkt. +c "s" option in main xtup input after "x": slope tweak for bracket. mult(4) is +c flag, mult(5-9) is tweak value+16 +c 2.409 +c Bugfix in docrd for MIDI: Use original pitch in case main/chord were +c switched due to 2nds. +c Remove "o" from error message for "A" command. +c New syntax: optional instrument number separator ":" in movement +c break command to precede a 2-digit instrument. +c Conditional output formats for \setname at movement break to allow +c instrument numbers >9. +c Bugfix in coding to raise barno due to slur over line break (pmxb) +c Move date/version data statement in pmxab to a better place. +c 2.408 +c Allow pnotes{x} when x>9.995 (mod is only to format stmt in make2bar). +c Bug fix in \liftPAusep in notex.for and in pmx.tex +c Character variables for version and date +c For up-stem single graces slurred to down-stem, shift slur start left by +c 0.8 so slur doesn't get too short. +c Initialize and slide mult, same as other full-program variables in /all/. +c 2.407 +c Allow AN[n]"[partname]" to be parsed by scor2prt as filename for part n, +c 2.406 +c Alter PMX: put \dnstrut into \znotes in \starteq (for system spacing +c equalization). +c Put dimensions of double sharps and flats in crdacc (for chords). +c Bugfix: Use sepsymq in LineBreakTies(..) instead of '&' +c Use only first 4 bits of mult for multiplicity+8, so rest can be used +c for other stuff. +c Move stemlength stuff in nacc(27-30) to mult(27-30) to remove conflict. +c 2.405: Not published but saved for safety. +c Option Aph to write \special{header=psslurs.pro} top of each page, so +c dviselec will work OK. +c 2.404 +c Allow slur to end on rest, but not start on a rest. Efaults height +c of ending is default height of start (before any automatic or user- +c defined djustments). User may adjust height as normal from default. +c 2.403 +c Bugfix: turn off repeated beaming patterns.at end of non-last voice. +c 2.402 +c Automatic repeated forced beams. Start with "[:" End with next explicit +c forced beam or end of input block. +c Increase # of forced beams per line of music per input block from 20 to 40 +c 2.401 +c Optional K-Postscript Linebreak Ties, Apl. New subroutine LineBreakTies. +c Makes 1st part normal shape, and starts 2nd part a little further left. +c Enable arpeggios in xtuplets. Had to make time itar(narp) a real. +c 2.40 +c Set up WrotePsslurDefaults (logical) so only write defaults on 1st Ap. +c Fix non-ps-slur input to \midslur (third signed integer). Do not reverse +c sign for down-slurs. +c 2.359 +c Add error exit subroutine stop1 to make exit status g77-compatible.. +c Absolute octave on xtup chord note was 2 octave too high, fixed in getnote +c Fermata on vertically shifted rest: special trap in putorn() to set height. +c Correct multiple grace note spacing for small staves (in dograce, +c define wheadpt1 depending on staff size) +c 2.358 +c Allow curvature corrections at start of postscript slur, in dopsslur() +c Local slur options p[+|-][s|t] for [nos|s]luradjust,[not|t]ieadjust +c Options for [Nos|S]luradjust,[Not|T]ieadjust,[noh|h]alfties: Ap[+|-][s|t|h] +c Make t[ID] act like s[ID]t, most mods in spsslur(). +c Add spsslur() to read in data for ps slurs, call from getnote. +c In beamstrt, save args for SetupB in common comipb to save them for +c 2nd call when xtup starts with rest +c Add spacing for ornament ")" as if it were accidental, in make2bar(). +c Horiz shift start and end of ps ties, dep. on stem dir'n, in dopsslur() +c Horiz. shift start of ps grace slur, 2 places in dograce(). +c Horiz shift end of grace slur in endslur() +c Make st slurs into postscript ties. Separate subroutine dopsslur(), +c Non-beamed xtup: "a" in 1st note or rest, before "x" (sets drawbm=.false.) +c Allow two D"x" on same note. Introduced jtxtdyn1 in dodyn. +c 2.357a +c Fix missing "end" in backfill.com, too-long lines in g1etnote, getnote +c 2.357 +c Increase dimension for # of lit TeX strings from 52 to 83. +c Allow blank rest in middle of xtuplet. Only mods in g*etnote(). +c 2.356 +c Increased some dimensions from 30 to 40 to allow up to 40 pages. +c In unbeamed xtups, "n" did not suppress bracket. Fixed in beamstrt(). +c Fix parsing of "f,h,H,HH" in sslur. +c Fix bug with cdot, note-level for slur termination (in getnote) +c 2.355 +c Midi transposition: IT[+|-][n1][+|-][n2]...[+|-][n(noinst)], +c n=# of half-steps. Restrict to mult. of 12 now, to avoid key-sig issues +c Make midi recognize ps ties in doslur. +c Correct ttieforsl so that it eats 2nd argument properly, using \zcharnote +c to get octave right. +c 2.354 +c With postscript slurs, make t-slurs real ties by inserting replacement +c macros \tieforisu, etc, defined in pmx.tex +c Check for open cresc or decresc at end of input block, using list[de]cresc +c Hairpin syntax conditional on postscript slurs. Backup to fill in start +c level, using new backfill(...). Separate height tweaks for +c start and finish. +c 2.353 +c K-0+n to transpose by half step (rather than just change key) +c Allow "rm[n]" when nv>1. Require it in all parts. Just write a stack of +c \mbrest's +c Enable "Rz"; define \setzalaligne in pmx.tex. Special treatment at end +c of input block before movement break, and at start of block after +c movement break, using \newmovement rather than \setzalaligne, since +c former already redefines \stoppiece. In second case, set rptfg2='z'. +c Make clefq(nm) common between pmxb and getnote; change references in +c getnote at 'M' to array elements, setting all new clefs as you go. +c 2.352 +c Remove \parskip redefinition from pmx.tex; write it into TeX file when +c "Ae" is invoked. +c Ap to activate postscript slurs. Add macro \psforts to pmx.tex to redefine +c \tslur in case \midslur was used. Allow slur inputs 'f','h','H','HH', +c translate them thru mapping to (1,4,5,6) as \midslur params, then let +c \psforts translate them back to ps slur macors. +c 2.351 +c Number slurs from 0 up instead of 11 down, anticipating postscript slurs. +c Write "\eightrm" instead of "\cmr8" for \figfont with small baseline size. +c Increase length of basenameq to 44 characters everywhere. +c Increase dimension of mcpitch (midi-chord-pitch) to 20. +c Set default systems per page to 1 if nv>7 +c In pmxb, move place where isystpg is reset to 0, so that \eject gets +c written when there is just one system per page. +c 2.35 +c Cautionary accidentals with 'c' anywhere in note symbol. +c NEW pmx.tex with \resetsize to set size to normal or small depending on +c current \internote. Used with new coding in dograce() to get right +c new size in case user has \setsize'ed some lines to \smallvalue. For +c \smallvalue-sized staves, redefine \tinynotesize to give 11-pt font. +c Affects pmx.tex. +c Continuation figure with fractional length. May now mix with other figures. +c If another figure follow Cont-fig, separate with colon. +c 2.342 +c Bugfix in getnote to recognize relative octave shift in grace at start of +c input block. +c In make2bar, initialize islhgt=0 earlier than before (possible solution +c to Suse g77 compile problem that I could not reproduce).. +c Bugfix in beamstrt & beamn1 for r2x6 c4D d d d +c 2.341 +c Syntax check: Forced page break page number must be > than previous. +c Bugfix: Define ivx when "sliding down" breath/caesure data in pmxb. +c 2.34 +c New pmx.tex with redefined liftpausc +c Bug fix with dotted, non-beamed xtups. +c 2.332 +c Fix bugs in horizonal shifts, spacing, for accid's, graces, noteheads. +c Allow arbitrary pos. input to W in g1etnote and getnote. +c 2.331 +c Bug-fix in dodyn(..): typo on length of arg of txtdyn +c 2.33 +c Caesura (oc), breath (ob). Set iornq(28), store rest of data in ibcdata() +c 2.321 +c Rescale accidental shifts. Still use 7 bits but now map (0,127) +c onto (-1.,5.35) +c Fix ihornb bug in dodyn, seen with dynamics on lower-voice non-beamed xtups +c 2.32 (Noticed after posting) +c Prohibit "/" as figure. +c 2.32 (Posted) +c Tidied up accidentals in chords, do spacing. +c Still to do: +c check for "(" on chord notes in spacing algo +c small accids +c double accids +c autoshift slurs +c 2.310 +c Extra call to precrd ahead of spacing chk, and single-note crd/acc +c shifts seem OK, but not multiple. crd/acc shifts not recorded 1st time. +c 2.309 +c Alternate algo for accid shifts in chords. +c 2.308 +c Auto horiz. notehead shifting added to precrd. +c 2.307 +c Auto shifting of multiple accidentals in chords. +c "Ao" in main chord note to keep accidentals in order. Set nacc(28). +c If there are any manual main or chord note shifts, then +c If any manual shift is preceded by "A" then +c 1. Auto-shifting proceeds +c 2. "A"-shifts add to autoshifts +c 3. non-"A" shifts are ignored! +c Else (>0 man shifts, none has "A") +c No auto-ordering, No autoshifts, +c End if +c End if +c 2.306 +c Initialize legacy note level to middle C in case user forgets to set +c octave. +c Shift xtup note? +c Shift in elemskips rather than noteheads? +c 2.305 +c Stop pmxb from multiple endvolta's at start of new page. +c 2.304 +c "Sx" in a note means shorten stemlength by x \internotes. "Sx:" turn on +c for multiple notes in the voice, "S:" last shortened note. +c 2.303 +c vshrink stuff all OK? Description is in pmxb. +c 2.302 +c Toggle vshrink with "Av". vshrink normally kicks in when \interstaff +c hits 20. This still needs work. +c Add " /" to last line if last char is not % or /. +c 2.301 +c Check in beamn1 for single note before multiplicity down-up. +c allow '.PMX' as well as '.pmx' +c 2.299 +c Correct typo in pmxb involving PMXbarnotrue. +c Replacement printed number for xtup: Unsigned integer after 'n' after 'x' +c Minor upgrade parsing xtuplet options 'x...' +c Correct dimension of nxtinbm in make2bar. +c 2.298 +c Account for doubled xtup notes in subroutine getx (user-defined spaces), +c by adding ndoub as an argument.. +c 2.297 +c Created and solved compiler problem. Put drawbm(NM) in its own common. +c Add new def'ns [\a|PA]usc, \lift[pa|PA]usc to pmx.tex, use them in make2bar +c when \centerbar is used. +c Modify \mbrest & \CenterBar in pmx.tex to use \volta@endcor etc. Have PMX +c use right 2nd and 3rd args for \mbrest when key, meter, or clef changes. +c 2.296 +c Correct printed numbers for forced beams with multiple xtups. For each beam +c make list in setupb by voice of eloff (h-offset) and mtupv (printed #) +c Increase lengths of jobname and infileq by 20 characters +c Enable whole notes and breves as 1st or last note of xtup in beamn1 and +c beamend, and wholes in beamid. +c 2.295 +c Midi balance Ib[n1]:[n2]:...[nn] +c Single-slope beam groups [...]-[...] +c Trap "i" unless after accidental (main notes, xtups, chord notes) +c 2.294 +c Unequal xtups with "D" to double a note in an xtup. +c As above, "F" will (a) increase multiplicity by 1 for marked note and next +c one and (b) add a dot to the first one. +c Fix bug with e.g. c84 [ .d e.f ] by checking whether forced beam is on +c when "." is encountered, then correcting beam start time.(end of getnote) +c MIDI velocity (volume) set: Iv[n1]:[n2]:[n3]... +c 2.293 +c Check for single notes spanning bar lines. +c Correct various bugs with staff-jumping beams. (1) for 2nd segment, vxtup +c must be set in make2bar since beamstrt is not called, fixing problem with +c dot at end. (2) add ivjb2 to flag which voice has 2nd segment and fix +c problem when >2 staves. +c Add nodur to args of dodyn, so can check if stemless and avoid height tweak +c Correct bug in getdyn setting flag in idynda2(0) for manual horiz. tweak +c 2.292a +c Undo syntax check for Type 2 or 3 TeX string starting in column 1. +c Meanwhile, Werner's problem with a mid-line Type 3 string has gone away?! +c 2.292 +c Allow comments in xtuplets +c Enable multiple octave jumps in grace notes. +c Allow dynamics in xtuplets. +c Fix bug in getdyn searching for end of text string (correct length of lineq +c to 128) +c Fix bug in dodyn, must ignore horiz. interaction tweak for +c user-text (idno = 0) +c Syntax check for Type 2 or 3 TeX string starting in column 1 +c (NOTE: later undone!) +c Syntax check for page number > npages at forced line break. +c 2.291 +c Fix error in AS command (accid spacing for small systems), making only +c one spec per staff, nv total. +c Stop using MIDI channel 10 +c 2.29 +c Fix error in console output format for # of bytes used in MIDI file. +c Fix bug in dograce so no space is added between grace and main note when +c there is a MIDI-only accidental. +c Fix bug so oes?+4 works. It was too ugly to explain. +c ...Different ways of storing accidental specs on input and output. +c No longer zap \writezbarno in special situations. +c Fix bug in dyntxt level on rest +c Line spacing equalization. Add macros \starteq, \endeq, \spread, etc. +c Activate with Ae. (Maybe later could input alternate values for +c \upamt, \dnamt, \parskip). Put \starteq on 1st note in voice 1 +c in the page, and \endeq on 1st note of next-to-last line in page. +c 2.28 +c Flip direction of forced beam "[f..." +c Fix beam numbering for staff jumping beams. Uses irest(23,24,29,30) +c Fix bug in sliding ip's for txtdyn's +c In dyn's allow vert. offsets +/-64, horiz +/-25.6 (store in idnyda2(1-99) +c 2.27 +c Comment out lines in dodyn checking number of dynamic marks found. Voice +c order may not be monotonic if two lines on a staff. +c Literal dynamic: D"[text]" +c 2.26 +c Allow hairpin start-stop on same note by disabling auto-tweaks in dodyn, +c increasing dimension of idynn to 4 to allow 4 symbols on same note. +c Increase voltxtq length from 10 to 20. +c AS[-/0][-/0]... to inform PMX that "-" voices are small, and rough +c accounting for ast's is done by defining effective headwidth +c whead1 in makebar2 to be 0.8*whead. +c 2.25 +c Fix logic bug with sepsym's when # of instruments changes. +c Slight increases in default offsets for hairpin starts after "p" +c 2.24 +c Hairpins D< or D> as toggle. +c Many automatic position tweaks for letter-group dynamics and hairpins. +c 2.23 +c Continued rhythmic shortcuts: space followed by "." or "," +c 2.22 +c In call to doslur, change tno(...) to tnote(...). This was only +c used when checking to slurs per stem directions, and should have been +c the note duration all along. +c MIDI-only accidental, bit 17 in nacc, or 27 in icrdat. +c Use "i" anywhere in note symbol. +c 2.21 +c Increase from 20 to 30 dimensions for movement breaks and midi sections. +c Fix out-of-order declarations per mutex comments +c Add "Bad error" and "Kluging" messages to log file. +c 2.197 +c add /comips/ to save tie-check midi variables +c For spacing of clef changes at start of input block, changed integer time +c lastnodur to prevtn, so it works with xtups. Possible incompatibility! +c 2.196 +c Fix Ickbug with time check in ncmid() +c Interchange \fermataup7 and \pausec to get proper alignment +c Enable French violin clef "f", number 7 in PMX, but 9 in MusiXTeX. +c Add defn's of \hsp, \hspp to pmx.tex +c Fix pre-slurs on xtup chord notes. +c Fixed raised PAuse, define \liftPAuse +c Replace \zbreve\sk with \breve. +c Made "1" work as mtrdenl by doubling it and mtrnuml. BUT WAIT...what +c about "o" and 1 as shorthand for 16???? Search for "Kluge" +c Added "vo" (voice) as MIDI instrument 55 +c Allow 3-digit page numbers (search for "toppageno") +c Fix bug caused by prior fix (cancelling accid after bar line was ignored). +c Fix double accids in chords +c 2.194 +c Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if +c block. +c Add meter to MIDI file with every pause +c Purify FORTRAN? +c 2.193 +c Increased # of in-line TeX strings from 36 to 52. +c Fix entry of # of bytes in header of tempo/meter/key track to allow >255. +c 2.191 +c Event track: Tempos, meters, keys all together. Data in comevent +c 2.15 +c Pretty good midi capability. Still no attention to slurs on chord notes. +c 2.11 +c 11 Dec 99 c rm1 +c 11 Dec 99 "oes?", "oe?" +c 11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes +c 11 Dec 99 Error message for shifted, repeated ornaments. +c 2.10 (Version 2.1) +c Fix bug with lowdot and xtuplets +c 2.09 +c Fix bug with multiple ornament heights over beams, when one is . or _ +c Error message from pmxa if rest on last note of xtup. +c Enable 12 slurs. +c Reinstate multiple rests at start of xtup. +c 2.07 +c Combine consecutive type-1 TeX strings. +c \midslur and \curve as 3rd signed digit in slur termination, + 2 opt.int's. +c Fixed breve chord notes in docrd +c Check irest(28) as well as vxtup when setting nodur for chord notes, since +c vxtup isn't set until 1st *main* note in xtup +c Vectorize nolev1, slope, ixrest. Klug fix for xtups with variable spacing. +c 2.06+ +c Make deterministic the beam slope calculation when there are an even # of +c slopes in list and middle two are equal magnitude but opposite sign. +c pmxa Trap for "o:" before 1st note in block +c Partial bug fix for 64th notes in xtuplets. +c Make ixrest a vector, since with new time scheme may not finish xtup in +c same notes block. +c Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb) +c 2.06 +c Account for changes in nv when computing \interstaff. Add a counter +c nistaff(iflb) = # of interstaff spaces per system = nv-1. Set whenever +c setting isysflb(iflb). Note nv can only change at a forced line break. +c Note also, iflb starts at 0! +c 2.05 +c Automatic start of new notes group with part 2 of staff-jump beam +c In make1bar, set irest bit 29 of lowest-voice note at same time, +c use as flag when making notes groups. +c For now, remove dummy blank line at end...it zaps terminal repeats. +c 2.02 +c Fixed slur-counting bug for multiple, slurred, aftergraces. +c 2.01 +c Increase to ask(1400) +c Increase max forced page breaks to 18 +c Define pausc for centered pause +c 2.0a +c Insert dummy blank line at very end to handle input files w/o terminal CR-LF +c pmx03r +c Option m[n] in S symbol to change musicsize (for parts) +c Double dotted rests now work. +c Write file name to log file +c Check existence of input file +c Allow 24-char jobname, may end with ".pmx" +c Comment out time stuff +c Replace 3-argument getarg with 2-argument + iargc +c Fix bug with negative noinst due to nint<=int replacement +c move lovation of iv in isdat1 to allow iv>7. +c Set nm=12 +c pmx03q +c replace int(x+.001) with nint(x) +c Write TeX file name to screen and to pml. +c Replace char(...) with chax(...) to sovle msdev bug. +c Bug fix: macro terminations when M is on a line by itself. +c Bug fix: don't accumulate space for XS in pmxa. +c Streamline Macros: use pointers to bufq instead of scratch files +c pmx03p +c Store input file in single character array bufq. +c lbuf(i)*2 is length of line i +c ipbuf is position just before next line to be read. +c pmx03 +c Optimize read/writes +c pmx02 +c Fix line count (for errors) when there are saved macros +c pmx01 +c In optimize mode, open/close macros (Watch out for residual zz files!) +c Command line input +c Option Ao to optimize, otherwise normal processing +c +ccccccc + parameter (nks=125,nm=24,mv=24576,maxblks=4000) + character*128 lnholdq + character*65536 bufq + integer*2 lbuf(maxblks) + common /comevent/ miditime,lasttime + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + common /commus/ musize,whead20 + integer*4 nbars0(nks),nbars(nks),ipoe(nks),nbari(nks) + real*4 poe0(nks),poe(nks) + logical isfirst,optimize + logical*4 fexist + character*44 jobname + character*47 infileq + common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), + * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, + * idum,itsofar(nm),nib(nm,15),nn(nm), + * rest(nm,200),lenbr0,lenbr1,firstline,newmeter + logical rest,firstline,newmeter + common /comdiag/ n69(0:nm),n34(0:nm) + logical mmacrec,gottempo + common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, + * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), + * mmacrec,gottempo + common /truelinecount/ linewcom(20000) +c +c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing +c nmidsec section starts and stops based on PLAYING macros (not recording). +c +ccccccccccccccccccccccccc +c + data date /'18 Aug 12'/ + data version /'2619'/ +c +ccccccccccccccccccccccccc + data maxit,ncalls /200,0/ + data isfirst /.true./ +c itstart = mytime() + versionc = version +c +c Initialize midi parameters +c + gottempo = .false. + ismidi = .false. + debugmidi = .false. + relacc = .false. + mmacrec = .false. + nmidsec = 1 + mgap = 10 + miditime = 0 + lasttime = 0 + nmidcrd = 0 + nusebl = 0 + notmain = .false. + do 3 ivx = 1 , nm + twoline(ivx) = .false. + midinst(ivx) = 6 + midivel(ivx) = 127 + midibal(ivx) = 64 + miditran(ivx) = 0 +3 continue + do 12 icm = 0 , nm + imidi(icm) = 0 + restpend(icm) = .false. + trest(icm) = 0. + levson(icm) = 0 + levsoff(icm) = 0 + slmon(icm) = .false. + naccbl(icm) = 0 + n69(icm) = 0 + n34(icm) = 0 + msecstrt(icm,1) = 1 +12 continue +c +c End of midi parameter initialization +c + musize = 0 + optimize = .false. + numargs = iargc() + if (numargs .eq. 0) then + print*,'You could have entered a jobname on the command line,' + print*,' but you may enter one now:' + read(*,'(a)')jobname + numargs = 1 + else + call getarg(1,jobname,idum) ! May need to replace this w/ next line +c call getarg(1,jobname) + end if +10 ljob = lenstr(jobname,44) + if (ljob .gt. 44) then + print*,'Jobname is too long. Try again.' + call stop1() + else if (ljob .eq. 0) then + print*,'No was jobname entered. Try again.' + call stop1() + else if (numargs .eq. 2) then + if (ljob.eq.2 .and. jobname(1:2).eq.'-o') then + optimize = .true. + call getarg(2,jobname,idum) ! May need to replace this w/ next line +c call getarg(2,jobname) + numargs = 1 + go to 10 + else + print*,'Illegal option on command line' + call stop1() + end if + end if +c +c Strip ".pmx" if necessary +c + ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX')) + if (ndxpmx .gt. 0) then + jobname = jobname(1:ndxpmx-1) + ljob = ljob-4 + end if +c +c Check for existence of input file +c + infileq = jobname(1:ljob)//'.pmx' + inquire(file=infileq,EXIST=fexist) + if (.not.fexist) then + inquire(file=jobname(1:ljob)//'.PMX',EXIST=fexist) + if (.not.fexist) then + print*,'Cannot find file '//infileq + call stop1() + else + infileq = jobname(1:ljob)//'.PMX' + end if + end if +c +c Open a log file +c + open(15,file=jobname(1:ljob)//'.pml') + call printl('This is PMX, Version '//version//', '//date) + ljob4 = ljob + call printl('Opening '//infileq) + open(18,file=infileq) +c +c Copy input file into common buffer +c + ipbuf = 0 + linewcom(1) = 1 + do 8 ilbuf = 1 , maxblks + ncomments = 0 +14 read(18,'(a)',end=9)lnholdq + lbuf(ilbuf) = lenstr(lnholdq,128) + if (lbuf(ilbuf) .eq. 0) then +c +c Blank line. Make it a single blank with length 1 +c + lbuf(ilbuf) = 1 + lnholdq = ' ' + end if +c +c Now line has at least one non blank character. Check for comment +c As of Version 260, do not copy comments into bufq +c But need to count %'s for error messaging +c if (lnholdq(1:1).eq.'%') go to 14 + if (lnholdq(1:1).eq.'%') then + ncomments = ncomments+1 + go to 14 + end if +c +c When here, have counted all preceding comments and have a real line +c + if (ilbuf .gt. 1) then + linewcom(ilbuf) = linewcom(ilbuf-1)+1+ncomments + else + linewcom(1) = 1+ncomments + end if + if (ipbuf+lbuf(ilbuf).gt.65536) then + print*,'Too many characters in file, stopping' + call stop1() + end if + bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) = lnholdq + ipbuf = ipbuf+lbuf(ilbuf) +8 continue + call printl('Too many lines in input file') + call stop1() +9 continue +c +c Insert dummy line to handle input files w/o CR-LF at end. +c + nlbuf = ilbuf-1 +c nlbuf = ilbuf +c bufq(ipbuf+1:ipbuf+3) = ' / ' +c lbuf(nlbuf) = 3 + close(18) + do 6 numit = 1 , maxit + if (optimize) call printl('Starting an iteration') +c +c When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0. +c Otherwise, nbars0 is the input +c When islast=.false., pmxb only returns poe's, otherwise does whole job +c + call pmxa(jobname,ljob4,isfirst,nsyst,nbars0,optimize) + if (.not.optimize) then + if (ismidi) then +c +c Set up channel numbers for midi. +c + numchan = 0 + do 11 iv = nv , 1 , -1 + if (twoline(iv)) then + midchan(iv,2) = numchan + numchan = numchan+1 + end if + midchan(iv,1) = numchan + numchan = numchan+1 +11 continue +c +c numchan will now be the number of channels, but max channel # is numchan-1 +c +c Set up velocities, balances, and midi-transpositions +c + do 13 iv = nv , 1 , -1 + if (twoline(iv)) then + midvelc(midchan(iv,2)) = midivel(iv) + midbc(midchan(iv,2)) = midibal(iv) + midtc(midchan(iv,2)) = miditran(iv) + end if + midvelc(midchan(iv,1)) = midivel(iv) + midbc(midchan(iv,1)) = midibal(iv) + midtc(midchan(iv,1)) = miditran(iv) +13 continue + end if +c +c TEMPORARY!!! +c + write(15,*)'nlbuf: ',nlbuf + ip1 = 1 + do 10000 ilb = 1 , nlbuf +c write(15,'(2i5,a40,3i5)')ilb,lbuf(ilb), +c * bufq(ip1:ip1+lbuf(ilb)-1), +c * (ichar(bufq(ip1+lbuf(ilb)-k:ip1+lbuf(ilb)-k)), +c * k=min(3,lbuf(ilb)),1,-1) + ip1 = ip1+lbuf(ilb) +10000 continue + iplast = ip1-1 +c +c Check to see if (1) last line is "<blank><blank>/" and (2) next to last +c line is "/" +c +c print*,'iplast:',iplast +c print*,'Last line:' +c print*,bufq(iplast+1-lbuf(nlbuf):iplast) +c print*,'Last char of next to last line:' +c print*,bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)) + if (bufq(iplast+1-lbuf(nlbuf):iplast) .eq. ' /') then + if (bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)).eq.'/') then + print*,'Removing last line of "<blank><blank>/"' + write(15,*)'Removing last line of "<blank><blank>/"' + nlbuf = nlbuf-1 + end if + end if +c + call pmxb(.true.,poe0,ncalls,optimize) + if (ismidi) then +c +c Write midi file +c + open(51,file=jobname(1:ljob)//'.mid') + if (debugmidi) open(52,file=jobname(1:ljob)//'.dbm') + call printl(' ') + call printl('Writing '//jobname(1:ljob)//'.mid') + call writemidi(jobname,ljob) + end if + close(15) + stop + end if + write(15,*)'nlbuf: ',nlbuf + ip1 = 1 + call pmxb(.false.,poe0,ncalls,optimize) + call poestats(nsyst,poe0,poebar0,devnorm0) +c +c Save initial deviation and line breaks for later comparison +c + if (numit .eq. 1) then + devpmx = devnorm0 + do 20 isys = 1 , nsyst + nbari(isys) = nbars0(isys) +20 continue + end if + call sortpoe(nsyst,poe0,ipoe) + do 1 iupord = nsyst , 1 , -1 + isysu = ipoe(iupord) + print*,'isysu=',isysu + write(15,*)'isysu=',isysu +c +c Skip if system isysu has poe0 < avg or isysd has poe0 > avg +c + if (poe0(isysu).lt.poebar0) go to 1 + do 5 idnord = 1 , nsyst + isysd = ipoe(idnord) + if (isysu.eq.isysd .or. nbars0(isysd).eq.1 + * .or. poe0(isysd).gt.poebar0) go to 5 + do 2 isyst = 1 , nsyst + nbars(isyst) = nbars0(isyst) + if (isyst .eq. isysu) then + nbars(isyst) = nbars(isyst)+1 + else if (isyst .eq. isysd) then + nbars(isyst) = nbars(isyst)-1 + end if +2 continue + call pmxa(jobname,ljob4,isfirst,nsyst,nbars,optimize) + call pmxb(.false.,poe,ncalls,optimize) + call poestats(nsyst,poe,poebar,devnorm) + if (devnorm .lt. devnorm0) then + devnorm0 = devnorm + poebar0 = poebar + do 4 isys = 1 , nsyst + nbars0(isys) = nbars(isys) + poe0(isys) = poe(isys) +4 continue + print*,'Improved with iup,idown,devnorm:', + * isysu,isysd,devnorm0 + write(15,*)'Improved with iup,idown,devnorm:', + * isysu,isysd,devnorm0 + write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + call sortpoe(nsyst,poe0,ipoe) + go to 6 + end if +5 continue +1 continue +c +c If we get here, must have gone thru all switches and found nothing better, +c so done! +c + go to 7 +6 continue +7 continue + print*,'Optimum located, numit:',numit,', ncalls:',ncalls + write(15,*)'Optimum located, numit:',numit,', ncalls:',ncalls + print*,'Final error:',devnorm0,', initial error:',devpmx + write(15,*)'Final error:',devnorm0,', initial error:',devpmx + print*,'Percentage improvement:',100.*(1-devnorm0/devpmx) + write(15,*)'Percentage improvement:',100.*(1-devnorm0/devpmx) + call printl('Initial bars/system:') + write(*,'(5x,20i3)')(nbari(isys),isys=1,nsyst) + write(15,'(5x,20i3)')(nbari(isys),isys=1,nsyst) + call printl('Final bars/system:') + write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst) + call pmxa(jobname,ljob4,.false.,nsyst,nbars0,optimize) + call pmxb(.true.,poe0,ncalls,optimize) +c itend = mytime() +c print*,'Elapsed time in ms:',itend-itstart +c write(15,*)'Elapsed time in ms:',itend-itstart + close(15) + end + subroutine accsym(nacc,acsymq,lacc) + character*3 acsymq + iacc = iand(nacc,7) + if (iacc .eq. 1) then + acsymq = 'fl' + lacc = 2 + else if (iacc .eq. 2) then + acsymq = 'sh' + lacc = 2 + else if (iacc .eq. 3) then + acsymq = 'na' + lacc = 2 + else if (iacc .eq. 5) then + acsymq = 'dfl' + lacc = 3 + else if (iacc .eq. 6) then + acsymq = 'dsh' + lacc = 3 + else + print*,'bad accidental: ',iacc + end if + return + end + subroutine addask(taskn,waskn,elaskn, + * fixednew,scaldold,tglp1,isudsp) + parameter (nm=24) + logical isudsp + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comtol/ tol + if (isudsp) then +c +c Find which udsp we're dealing with +c + do 1 iudsp = 1 , nudsp + if (abs(taskn+tglp1-tudsp(iudsp)) .lt. tol) go to 2 +1 continue + print*,'You should note BEEE here in addask!' + call stop1() +2 continue +c +c Fixednew and scaldold must not be changed, since udsp's are already included +c in fsyst from pmxa, and udsp don't involve scaled space.. +c + if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then +c +c Must add user-defined space to what's there already. +c + wask(naskb) = wask(naskb)+udsp(iudsp) + else +c +c This place has no other space. +c + naskb = naskb+1 + task(naskb) = taskn + wask(naskb) = udsp(iudsp) + elask(naskb) = 0. + end if + else +c +c This is a normal space, no effect if smaller than existing space +c + if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then +c +c We already put in some space at this time +c Check if new one needs more space than old one at same time +c + if (waskn .gt. wask(naskb)) then + naskb = naskb-1 + else + return + end if + end if + naskb = naskb+1 + task(naskb) = taskn + wask(naskb) = waskn + elask(naskb) = elaskn + fixednew = fixednew+waskn + scaldold = scaldold+elaskn + end if + return + end + subroutine addblank(noteq,lnoten) + character*8 noteq + character*1 tchar + tchar = noteq + noteq = ' '//tchar + lnoten = 2 + return + end + subroutine addfb(nfb,iv,tnew,t1fb,t2fb,ulfbq,ifbadd) + parameter (nm=24) + integer nfb(nm) + common /comtol/ tol + real*4 t1fb(nm,20),t2fb(nm,20) + character*1 ulfbq(nm,20) + ifbadd = 1 + nfb(iv) = nfb(iv)+1 + do 1 ifb = nfb(iv)-1 , 1 , -1 + if (tnew .lt. t1fb(iv,ifb)-tol) then + t1fb(iv,ifb+1) = t1fb(iv,ifb) + t2fb(iv,ifb+1) = t2fb(iv,ifb) + ulfbq(iv,ifb+1) = ulfbq(iv,ifb) + else + ifbadd = ifb+1 + go to 2 + end if +1 continue +2 continue + t1fb(iv,ifbadd) = tnew + ulfbq(iv,ifbadd) = 'x' + return + end +c +c + subroutine addmidi(icm,nolev,iacc,isig,time,rest,endrest) + parameter(nm=24,mv=24576) + integer*2 mmidi,itk(25) + integer*4 itiesav(5,100) + character*1 notenumq + logical endrest,eximacc,it1found + logical rest + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + common /comevent/ miditime,lasttime + common /comdiag/ n69(0:nm),n34(0:nm) +c +c Following variables are local but must be saved. I hope they are. +c (3/18/00) With g77 they are not, so add a common block here. +c +c integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:12) + integer*2 ipslon(0:nm),lusebl(10),jusebl(10),icmm(0:15) + common /comips/ ipslon,lusebl,jusebl +c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ + data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/ +c +c Cancel out barline accidentals if there's a rest. +c + if (rest) naccbl(icm) = 0 +c +c Special path to insert dummy rest at end of a section +c + if (endrest) go to 20 +c + do 7 ion = 0 , nmidcrd +c +c check if this is only to get pitch of a chord note +c + if (notmain) go to 6 +c +c check for rest +c + if (rest) then +c +c Will not put in a note, but must update timing +c + if (.not.restpend(icm)) then +c +c First rest in sequence, save the time +c + restpend(icm) = .true. + trest(icm) = time + else + trest(icm) = trest(icm)+time + end if +c +c Note: code checkers don't like the above due to calling addmidi(trest(icm)) +c but this only happens if rest at end of section (endrest=.true.) (called +c from getmidi(), in which case these above lines are bypassed. +c + call chkimidi(icm) + return + end if +c +c time tics +c + if (imidi(icm).gt.0 .and. ion.eq.0) then + idur = mgap + else + idur = 0 + end if + if (restpend(icm)) then + restpend(icm) = .false. + idur = idur+nint(15*trest(icm)) + end if +c +c time to start of note +c + idurvar = isetvarlen(idur,nby2on) + if (nby2on .gt. 4) then + print*,'You got >4 bytes, something is bogus.' + call stop1() + end if + imidi(icm) = imidi(icm)+1 + do 2 i = 1 , nby2on +c +c imidi points to cell before highest (leftmost) byte. Start with lowest byte +c at far right, fill in backwards +c + mmidi(icm,imidi(icm)+nby2on-i) = mod(idurvar,256) + if (nby2on .gt. 1) idurvar = idurvar/256 +2 continue + imidi(icm) = imidi(icm)+nby2on-1 +c +c Note-on signal +c + imidi(icm) = imidi(icm)+1 +c mmidi(icm,imidi(icm)) = 9*16+icm + mmidi(icm,imidi(icm)) = 9*16+icmm(icm) +c +c Entry point for chord note pitch determination +c +6 continue +c +c Get midi pitch. On chord iteration, only do this first time (main note), +c since pitch was already computed for nonmain chord notes. +c + if (ion .eq. 0) then + ipsav = nolev*12./7+11 + ipsav0 = ipsav + if (isig .ne. 0) then +c +c Adjust for signature +c + notenumq = char(48+mod(nolev,7)) + if (isig.ge.index('4152630',notenumq)) then + ipsav = ipsav+1 + else if (-isig.ge.index('0362514',notenumq)) then + ipsav = ipsav-1 + end if + end if +c +c Deal with accidentals. +c +c iacc 0 1 2 3 4 5 6 7 +c effect X fl sh na X dfl dsh X +c iashft X -1 1 0 X -2 2 X +c + jacc = 0 + eximacc = .false. + if (iacc .gt. 0) then +c +c Adjust key-sig-adjusted pitch for explicit accidental (and exit) +c + jacc = iashft(iacc) + eximacc = .true. + if (.not.relacc) jacc = jacc+ipsav0-ipsav +c +c (Above) Shift applies to diatonic pitch but will be added to adjusted one +c + else if (naccim(icm) .gt. 0) then +c +c Possible implicit accidental from earlier in the bar +c Check for prior accid in this bar at this note level +c + do 3 kacc = 1 , naccim(icm) + if (laccim(icm,kacc) .eq. nolev) then + jacc = jaccim(icm,kacc) + eximacc = .true. + if (.not.relacc) jacc = jacc+ipsav0-ipsav + go to 4 + end if +3 continue +4 continue + end if +c +c Must split off the following if block from those above because chord +c notes can cause naccim>0, forcing us to miss other chord note's +c accross-bar-line accidental +c + if (naccbl(icm).gt.0 .and. .not.eximacc) then +c +c Possible carryover accid from prior bar (or prior same-pitch note). +c + do 21 kacc = 1 , naccbl(icm) + if (laccbl(icm,kacc) .eq. nolev) then + jacc = jaccbl(icm,kacc) +c +c Since we are *using* the bar-line accid, must flag it to be saved for next. +c + nusebl = nusebl+1 + jusebl(nusebl) = jacc + lusebl(nusebl) = nolev + if (.not.relacc) jacc = jacc+ipsav0-ipsav + go to 22 + end if +21 continue +22 continue + end if + ipsav = ipsav+jacc +c +c Midi transpositions +c + ipsav = ipsav+midtc(icm) + end if + if (notmain) then + mcpitch(nmidcrd) = ipsav +c +c Save pitch for tie checks +c + if (levson(icm).eq.nolev.and..not.slmon(icm)) + * ipslon(icm) = ipsav + else + imidi(icm) = imidi(icm)+1 + if (ion.eq.0) then + mmidi(icm,imidi(icm)) = ipsav + if (levson(icm).eq.nolev.and..not.slmon(icm)) + * ipslon(icm) = ipsav + else + mmidi(icm,imidi(icm)) = mcpitch(ion) + end if + end if + if (ion .eq. 0) then +c +c Only record accids for non-chords, main chord note during chord iteration +c and chordnotes on first call but not during iteration +c + if (iacc.gt.0) then +c +c Set marker for accidental for possible continuations later this bar +c but first check and clear earlier ones on same note. +c + do 23 kacc = 1 , naccim(icm) + if (laccim(icm,kacc) .eq. nolev) then + do 24 macc = kacc , naccim(icm)-1 + laccim(icm,macc) = laccim(icm,macc+1) + jaccim(icm,macc) = jaccim(icm,macc+1) +24 continue + go to 25 + end if +23 continue + go to 26 +25 continue + naccim(icm) = naccim(icm)-1 +26 continue +c +c Flag new accidental +c + naccim(icm) = naccim(icm)+1 + laccim(icm,naccim(icm)) = nolev + jaccim(icm,naccim(icm)) = iashft(iacc) + end if +c +c Bail if this is a chord note on the first call (from docrd) +c + if (notmain) then + call chkimidi(icm) + return + end if + end if +c +c Vel +c + imidi(icm) = imidi(icm)+1 +c mmidi(icm,imidi(icm)) = 127 + mmidi(icm,imidi(icm)) = midvelc(icm) + call chkimidi(icm) +7 continue +c +c For tie checks +c + if (levson(icm).gt.0.and..not.slmon(icm)) imidso(icm) = imidi(icm) +c +c Entry point for special rests at section ends (endrest=T) +c +20 continue +c +c Now insert all the ends +c + do 8 ioff = 0 , nmidcrd + if (ioff .eq. 0) then +c +c time to end +c + idur1 = nint(15*time) + if (.not.endrest .or. miditime.eq.nint(15*trest(icm))) then + idur = idur1-mgap + else + idur = idur1 + end if +c +c Deal with roundoff problems with 7-tuplets on half or quarters +c + if (idur1 .eq. 69) then + n69(icm) = n69(icm)+1 +c if (mod(n69(icm)+6,7) .gt. 3) idur = 58 + if (mod(n69(icm)+6,7) .gt. 3) idur = idur1-mgap-1 + else if (idur1 .eq. 34) then + n34(icm) = n34(icm)+1 + if (mod(n34(icm)+6,7) .gt. 4) idur = idur1-mgap+1 + end if + idurvar = isetvarlen(idur,nby2off) + if (nby2off .gt. 4) then + print*,'You got >4 bytes, something is bogus.' + call stop1() + end if + imidi(icm) = imidi(icm)+1 + call chkimidi(icm) + do 1 i = 1 , nby2off + mmidi(icm,imidi(icm)+nby2off-i) = mod(idurvar,256) + if (nby2off .gt. 1) idurvar = idurvar/256 +1 continue + imidi(icm) = imidi(icm)+nby2off-1 + else +c +c Inserting end of chord note, delta time is 0 +c + imidi(icm) = imidi(icm)+1 + mmidi(icm,imidi(icm)) = 0 + end if +c +c Note off +c + imidi(icm) = imidi(icm)+1 +c mmidi(icm,imidi(icm)) = 8*16+icm + mmidi(icm,imidi(icm)) = 8*16+icmm(icm) +c +c Pitch +c + imidi(icm) = imidi(icm)+1 + if (ioff .eq. 0) then + mmidi(icm,imidi(icm)) = ipsav + else + mmidi(icm,imidi(icm)) = mcpitch(ioff) + end if +c +c Vel +c + imidi(icm) = imidi(icm)+1 + mmidi(icm,imidi(icm)) = 0 + call chkimidi(icm) + if (endrest) then + return + end if +c +c print*,'Off, icm,imidi,ipsav,idur:',icm,imidi(icm),ipsav,time +c +8 continue + naccbl(icm) = nusebl + if (nusebl .gt. 0) then +c +c Fix tables of "bar-line" accids that are saved due to consecutive notes. +c + do 30 kacc = 1 , nusebl + laccbl(icm,kacc) = lusebl(kacc) + jaccbl(icm,kacc) = jusebl(kacc) +30 continue + nusebl = 0 + end if +c +c Begin tie checks +c + if (slmon(icm)) then +c +c Prior note had a slur start +c + if (levson(icm).eq.levsoff(icm) .and. iacc.eq.0) then +c +c We have a tie! (Assumed there would be no accidental on tie-ending note) +c Make a list of times of all events back to the one starting at imidso+1, +c which is at or before where the tie started. Ident tie start and stop by +c comparing pitches. Save the 4 pieces of data in itiesav(1...4,nsav4tie) +c Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial +c time. + nsav4tie = 0 + imidt = imidso(icm) +10 nsav4tie = nsav4tie+1 + itiesav(1,nsav4tie) = igetvarlen(mmidi,icm,imidt,nbytes) + imidt = imidt+nbytes + do 11 j = 1 , 3 + itiesav(j+1,nsav4tie) = mmidi(icm,imidt+j) +11 continue + imidt = imidt+3 + if (nsav4tie .eq. 1) then + itiesav(5,1) = itiesav(1,1) + else + itiesav(5,nsav4tie) = itiesav(1,nsav4tie)+ + * itiesav(5,nsav4tie-1) + end if + if (imidt .ne. imidi(icm)) go to 10 +c +c Find which two pitches agree with saved slur pitch. +c + it1found = .false. + do 12 it2 = 1 , nsav4tie + if (itiesav(3,it2) .eq. ipslon(icm)) then + if (it1found) go to 13 + it1 = it2 + it1found = .true. + end if +12 continue + call printl( + * 'Program error, tied notes, send source to Dr. Don') + it1 = nsav4tie+1 + it2 = nsav4tie+1 +13 continue +c +c List the positions we want to keep +c + jsav = 0 + do 14 isav = 1 , nsav4tie + if (isav.eq.it1 .or. isav.eq.it2) go to 14 + jsav = jsav+1 + itk(jsav) = isav +14 continue + nsav4tie = nsav4tie-2 +c +c Now dump events it1 & it2, recompute times, restack mmidi. +c + imidi(icm) = imidso(icm) + do 15 isav = 1 ,nsav4tie + if (isav .eq. 1) then + idurvar = isetvarlen(itiesav(5,itk(isav)),nbytes) + else + idurvar = isetvarlen(itiesav(5,itk(isav))- + * itiesav(5,itk(isav-1)),nbytes) + end if + imidi(icm) = imidi(icm)+1 + do 16 i = 1 , nbytes + mmidi(icm,imidi(icm)+nbytes-i) = mod(idurvar,256) + if (nbytes .gt. 1) idurvar = idurvar/256 +16 continue + imidi(icm) = imidi(icm)+nbytes-1 + do 17 i = 2 , 4 + imidi(icm) = imidi(icm)+1 + mmidi(icm,imidi(icm)) = itiesav(i,itk(isav)) +17 continue +15 continue + end if + slmon(icm) = .false. + levsoff(icm) = 0 + if (.not.dbltie) levson(icm) = 0 + end if + if (levson(icm).gt.0) slmon(icm) = .true. + if (nmidcrd .gt. 0) nmidcrd = 0 + call chkimidi(icm) + return + end + subroutine addstr(notexq,lnote,soutq,lsout) + common /comlast/ islast,usevshrink + logical islast,usevshrink + character*(*) notexq + character*80 soutq + if (lsout+lnote .gt. 72) then + if (islast) write(11,'(a)')soutq(1:lsout)//'%' + lsout = 0 + end if + if (lsout .gt. 0) then + soutq = soutq(1:lsout)//notexq(1:lnote) + else + soutq = notexq(1:lnote) + end if + lsout = lsout+lnote + return + end + subroutine adjusteskz(ib,squez,istart,istop,poenom) +c +c For block ib, this adds accidental spaces to eskz, for use in getting +c length of xtup bracket and slopes of brackets and beams. +c + parameter (nm=24) + common /comas1/ naskb,task(40),wask(40),elask(40) + real*4 squez(80) + integer*4 istart(80),istop(80) + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + common /comeskz2/ eskz2(nm,200) + common /comtol/ tol + common /comntot/ ntot + inmin = istart(ib)+1 + do 10 iaskb = 1 , naskb + if (task(iaskb) .lt. to(istart(ib))-tol) go to 10 + eskadd = wask(iaskb)/poenom-elask(iaskb) + do 11 in = inmin , ntot + if (to(in) .gt. task(iaskb)-tol) then + eskz2(ivxo(in),ipo(in)) = eskz2(ivxo(in),ipo(in))+eskadd + if (abs(to(in)-task(iaskb)).lt. tol) inmin=inmin-1 + else + inmin = inmin+1 + end if +11 continue +10 continue + return + end + subroutine askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0) + logical figbass,ispoi,topmods,istype0,done,isbbm + common /comhsp/ hpttot(176) + common /compoi/ ispoi + common /combbm/ isbbm + common /comas3/ ask(2500),iask,topmods + character*40 pathnameq + character*44 basenameq + character*1 sq,chax + character*129 outq + sq = chax(92) + open(12,file=pathnameq(1:lpath)//basenameq(1:lbase)//'.tex') +c +c Transfer first 5 lines of main internal TeX file +c + do 11 il = 1 , 5 + call moveln(11,12,done) +11 continue + if (istype0) then +c +c Transfer literal TeX stuff from special scratch file +c + rewind(17) +10 call moveln(17,12,done) + if (.not.done) go to 10 + close(17) + end if +c +c Transfer next 2 lines from main scratch file +c + do 3 il = 1 , 2 + call moveln(11,12,done) +3 continue + if (ispoi) write(12,'(a)')sq//'input musixpoi' + if (isbbm) write(12,'(a)')sq//'input musixbbm' + if (figbass) then +c +c Transfer .fig data from scratch (unit 14) into external .tex (unit 12) +c +4 call moveln(14,12,done) + if (.not.done) go to 4 + close(14) + end if + iask = 0 + ihs = 0 +1 read(11,'(a129)',end=999)outq +c +c Hardspaces. +c + if (outq(1:5) .eq. sq//'xard') then + ihs = ihs+1 + outq(2:2) = 'h' + write(outq(12:15),'(f4.1)')hpttot(ihs) + lenout = 19 + go to 9 + end if +c +c This part hard-wires ask's into new .tex file as ast's +c +2 indxask = index(outq,sq//'ask') + if (indxask .ne. 0) then + iask = iask+1 + call putast(ask(iask),indxask,outq) + go to 2 + end if + lenout = llen(outq,129) +9 continue + write(12,'(a)')outq(1:lenout) +c +c If this is the line with "readmod", check for topmods. +c + if (topmods .and. outq(2:8).eq.'readmod') then + topmods = .false. + rewind(16) + do 7 il = 1 , 1000 + read(16,'(a129)',end=8)outq + lenout = llen(outq,129) +c +c We inserted the '%' in subroutine littex, to guarantee including blank. +c + write(12,'(a)')outq(1:lenout) +7 continue +8 continue + close(16) + end if + go to 1 +999 close(11) + close(12) + return + end + subroutine backfill(iunit,oldq,lenold,newq,lennew) +c +c In iunit, looks backward for oldq, overwrites newq +c Safest if both are same length! +c + character*128 lineq(200),nowq + character*(*) oldq,newq + linesback = 0 +1 continue + backspace(iunit) + read(iunit,'(a)')nowq + ndx = index(nowq,oldq(1:lenold)) +c +c Save the line just read +c + linesback = linesback+1 + lineq(linesback) = nowq + if (ndx .eq. 0) then + backspace(iunit) + go to 1 + end if +c +c If here, it's replacement time. +c + lineq(linesback) = nowq(1:ndx-1)//newq(1:lennew) + * //nowq(ndx+lenold:128) + backspace(iunit) + do 2 line = linesback , 1 , -1 + write(iunit,'(a128)')lineq(line) +2 continue + return + end + subroutine beamend(notexq,lnote) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq,ulqq,chax + logical beamon,firstgulp,figbass,figchk,flipend,btest, + * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comoct/ noctup + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + character*4 tempq + character*8 noteq + character*79 notexq + ip = ipo(jn) + multip = iand(mult(ivx,ip),15)-8 + if (ixrest(ivx) .eq. 4) then +c +c This is the LAST note in the xtup (i.e., all rests before). Make single. +c + nodur(ivx,ip) = 2**(4-multip) + call notex(notexq,lnote) + ixrest(ivx) = 0 + return + end if + nole = nolev(ivx,ip) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ip),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ip),31)) then + nole = nole + 1 + end if + if (.not.drawbm(ivx)) then +c +c Xtuplet with no beam, just put in the right kind of note +c + if (btest(islur(ivx,ip),30)) then +c +c Forced stem direction +c + ndsav = nodur(ivx,ip) + nodur(ivx,ip) = 2**(4-multip) + if (btest(nacc(ivx,ip-1),27)) + * nodur(ivx,ip)=nodur(ivx,ip)/2 + call notex(notexq,lnote) + nodur(ivx,ip) = ndsav + else + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + lnote = lnoten+3 + if (.not.btest(nacc(ivx,ip-1),27)) then +c +c Prior note is not regular-dotted +c + + if (multip .eq. 0) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. -1) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. 1) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. 2) then + notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))//noteq + lnote = lnote+1 + else if (multip .eq. 3) then + notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))//noteq + lnote = lnote+2 + else if (multip .eq. -2) then + notexq = sq//'wh'//noteq + else if (multip .eq. -3) then + notexq = sq//'breve'//noteq + lnote = lnote+3 + else + print* + print*,'(Error in beamend, send source to Dr. Don)' + call stop1() + end if + else +c +c Prior note is regular-dotted so this one is halved +c + if (multip .eq. 0) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. -1) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq + else if (multip .eq. -2) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq + end if + end if + end if + return + end if + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + lnote = 0 +c +c New way, with flipend, which was computed in beamstrt. +c + if (flipend(ivx) .and. btest(ipl(ivx,ip),30)) + * ulq(ivx,ibmcnt(ivx)) = chax(225-ichar(ulq(ivx,ibmcnt(ivx)))) + if (ip .gt. ibm1(ivx,ibmcnt(ivx))) then +c +c This is not a one-noter from beam-jump. Check if multiplicity has increased +c + if (btest(irest(ivx,ip-1),0)) then +c +c Prior note is a rest, check one before that +c + mp = iand(mult(ivx,ip-2),15)-8 + else + mp = iand(mult(ivx,ip-1),15)-8 + end if + if (multip .gt. mp) then +c +c Assume 1-3, 2-3, or 1-2 +c + do 2 imp = multip , mp+1 , -1 + call ntrbbb(imp,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) +2 continue + else if (btest(nacc(ivx,ip-1),27)) then +c +c 2nd member of dotted xtup +c + call ntrbbb(multip+1,'t', + * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) + end if + end if +c +c Beam termination and direction analysis +c + if (btest(irest(ivx,ip),23) .and. .not.isbjmp) then +c +c This is the end of the first segment in a jump-beam. ivbj1=ivx will be number +c of the jump-beam. ivbj2 will be tested along with isbjmp to see if in the +c voice of the 2nd part of jumped beam. (May need special treatment for +c multi-segment jump-beams +c + isbjmp = .true. + ivbj1 = ivx + ivbj2 = 0 + end if + if (.not.btest(irest(ivx,ip),23)) then +c +c This is either a normal beamend or end of a sequence of jump-beam segments, +c so some sort of termination is required +c + ulqq = ulq(ivx,ibmcnt(ivx)) + if (.not.isbjmp .or. ivx.ne.ivbj2) then +c +c Normal termination +c + call ntrbbb(1,'t',ulqq,mod(ivx,24),notexq,lnote) + else +c +c Terminate a sequence of jump-beam segments. +c + ulqq = chax(225-ichar(ulqq)) + call ntrbbb(1,'t',ulqq,mod(ivbj1,24),notexq,lnote) + end if + end if +c +c And now the note +c + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'qb' + else + notexq = sq//'qb' + end if + lnote = lnote+3 + isdotm = .false. + if (.not.vxtup(ivx)) then + if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then + if (.not.btest(iornq(ivx,ip),13)) then + notexq = notexq(1:lnote)//'p' + else + notexq = notexq(1:lnote)//'m' + isdotm = .true. + end if + lnote = lnote+1 + end if + end if +c +c 5/25/08 Allow >12 +c 5/9/10 Up to 24; replace 24 with 0 +c + if (.not.(isbjmp.and.ivx.eq.ivbj2)) then +c call istring(mod(ivx,12),tempq,len) + call istring(mod(ivx,24),tempq,len) + else +c call istring(mod(ivbj1,12),tempq,len) + call istring(mod(ivbj1,24),tempq,len) + end if + if (isbjmp .and. ivx.eq.ivbj2 + * .and..not.btest(irest(ivx,ip),23)) isbjmp=.false. + notexq = notexq(1:lnote)//tempq(1:len) + lnote = lnote+len + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (isdotm) then + if (lnoten .eq. 1) then + notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + return + end + subroutine beamid(notexq,lnote) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq,ulqq,chax + logical beamon,firstgulp,figbass,figchk,flipend,btest, + * isfig,vxtup,isdotm,isbjmp,bar1syst,isdotted,isbj2,drawbm + character*79 notexq + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comoct/ noctup + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + character*8 noteq + character*4 tempq + lnote = 0 + ip = ipo(jn) + nole = nolev(ivx,ip) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ip),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ip),31)) then + nole = nole + 1 + end if + if (.not.btest(irest(ivx,ip),0)) then + multip = iand(mult(ivx,ip),15)-8 +c if (btest(islur(ivx,ip-1),3)) multip = multip+1 +c +c (Above test OK since must have ip>1). Double dotted note preceding +c +c Move the following, because can't ask for note until after checking for +c embedded xtup with number, due to ordering/octave feature. +c +c call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) + end if + if (btest(irest(ivx,ip),28)) vxtup(ivx) = .true. + if (vxtup(ivx)) then +c +c In an xtup +c + if (btest(irest(ivx,ip),0)) then +c +c Intermediate rest in xtup, put in the rest. Reset nodur so notex works OK +c + nodur(ivx,ip) = 2**(4-(iand(mult(ivx,ip),15)-8)) + call notex(notexq,lnote) +c +c Re-zero so next note does not get confused +c + nodur(ivx,ip) = 0 + return + end if +c if (multip.le.0) then +c if (multip.le.0 .or. +c * (multip.eq.1.and.btest(nacc(ivx,ip-1),18))) then + if (.not.drawbm(ivx)) then +c +c Xtuplet with no beam, just put in the right kind of note +c + if (btest(islur(ivx,ip),30)) then +c +c Forced stem direction +c + ndsav = nodur(ivx,ip) + nodur(ivx,ip) = 2**(4-multip) + if (btest(nacc(ivx,ip),19) .or. + * btest(nacc(ivx,ip),27)) then + nodur(ivx,ip)=3*nodur(ivx,ip)/2 + else if (btest(nacc(ivx,ip-1),27)) then + nodur(ivx,ip)=nodur(ivx,ip)/2 + end if + call notex(notexq,lnote) + nodur(ivx,ip) = ndsav + else +c +c Use ulq for stem direction +c + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + lnote = 3 + if (.not.btest(nacc(ivx,ip-1),27)) then +c +c Prior note is not regular-dotted +c + if (multip .eq. 0) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -1) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 1) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 2) then + notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx)) + lnote = 4 + else if (multip .eq. 3) then + notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx)) + lnote = 5 + else if (multip .eq. -2) then + notexq = sq//'wh' + end if + if (btest(nacc(ivx,ip),27)) then +c +c This note is regular dotted non-beamed xtup +c + notexq = notexq(1:3)//'p' + lnote = 4 + end if + else +c +c Prior note is regular-dotted so this one is halved +c + if (multip .eq. 0) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -1) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -2) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) + end if + end if + notexq = notexq(1:lnote)//noteq + lnote = lnote+lnoten + end if + return + else if (nodur(ivx,ip).eq.0) then +c +c In the beamed xtup but not the last note +c + if (nodur(ivx,ip-1).gt.0) then +c +c Embedded Xtup, mult>0, starts here. Put in number if needed +c + nxtinbm(ivx) = nxtinbm(ivx)+1 + iud = 1 + if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') iud = -1 +c +c Get ip#, notelevel of middle note (or gap) in xtup +c + ipmid = ip+ntupv(ivx,nxtinbm(ivx))/2 + xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud, + * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8) + if (mod(ntupv(ivx,nxtinbm(ivx)),2).eq.0) xnlmid = (xnlmid+ + * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud, + * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2 + iflop = 0 + if (abs(xnlmid-ncmid(iv,ip)).lt.3.) iflop = -iud + iup = iud+2*iflop + if (btest(irest(ivx,ip),14)) then + iup = -iup + iflop = 0 + if (iud*iup .lt. 0) iflop = iup + end if +c +c Place number if needed +c + if (.not.btest(islur(ivx,ip),31)) then + mprint = igetbits(nacc(ivx,ip),5,22) + if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx)) + call putxtn(mprint,iflop,multip,iud,wheadpt,poenom, + * nolev1(ivx),islope(ivx),slfac, + * xnlmid,islur(ivx,ip),lnote,notexq,ncmid(iv,ip),nlnum, + * eloff(ivx,nxtinbm(ivx)),iup,irest(ivx,ip),.false.) + end if + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + else +c +c Intermediate note of xtup +c + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + end if + else +c +c Last note of xtup (but not last note of beam!) +c + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + end if + else if (btest(irest(ivx,ip),0)) then + call notex(notexq,lnote) + return + else + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + end if +c +c Check if multiplicity changes in a way requiring action +c + ipleft = ip-1 + if (btest(irest(ivx,ipleft),0)) ipleft = ipleft-1 + if (.not.btest(islur(ivx,ipleft),20)) then + multl = iand(15,mult(ivx,ipleft))-8 + else + multl = 1 + end if + mub = multip - multl + ipright = ip+1 + if (btest(irest(ivx,ipright),0)) ipright = ipright+1 + if (.not.btest(islur(ivx,ip),20)) then + multr = iand(15,mult(ivx,ipright))-8 + else + multr = 1 + end if + mua = multr-multip + if (mub.gt.0 .or. mua .lt. 0) then +c +c Multiplicity has increased from left or will decrease to right. Need action. +c + if (isbjmp .and. ivx.eq.ivbj2) then + ivb = ivbj1 + ulqq = chax(225-ichar(ulq(ivx,ibmcnt(ivx)))) + else + ivb = ivx + ulqq = ulq(ivx,ibmcnt(ivx)) + end if + if (mua .ge. 0) then + call ntrbbb(multip,'n',ulqq,ivb,notexq,lnote) + else if (multl .ge. multr) then + do 1 im = multip , 1+multr, -1 + call ntrbbb(im,'t',ulqq,ivb,notexq,lnote) +1 continue + else + do 2 im = 1+multr, multip + call ntrbbb(im,'r',ulqq,ivb,notexq,lnote) +2 continue + call ntrbbb(multr,'n',ulqq,ivb,notexq,lnote) + end if + else if (ip .gt. 1) then +c +c Check for 2nd member of dotted xtup +c + if (btest(nacc(ivx,ip-1),27)) call ntrbbb(multip+1,'t', + * ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) + end if +c +c Now put in the note +c + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'qb' + else + notexq = sq//'qb' + end if + lnote = lnote+3 + isdotm = .false. + if (isdotted(nodur,ivx,ip)) then +c +c rule out ')' +c + if (.not.btest(iornq(ivx,ip),13)) then + if (.not.btest(islur(ivx,ip),3)) then + notexq = notexq(1:lnote)//'p' + else +c +c Double dot +c + notexq = notexq(1:lnote)//'pp' + lnote = lnote+1 + end if + else + notexq = notexq(1:lnote)//'m' + isdotm = .true. + end if + lnote = lnote+1 + else if (btest(nacc(ivx,ip),19) + * .or. btest(nacc(ivx,ip),27)) then +c +c Special dotted notation for 2:1 xtup, or normal dot in xtup +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + end if +c +c 5/25/08 Allow >12 +c + if (.not.(isbjmp.and.ivx.eq.ivbj2)) then +c call istring(mod(ivx,12),tempq,len) + call istring(mod(ivx,24),tempq,len) + else +c call istring(mod(ivbj1,12),tempq,len) + call istring(mod(ivbj1,24),tempq,len) + end if + notexq = notexq(1:lnote)//tempq(1:len) + lnote = lnote+len + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (isdotm) then + if (lnoten .eq. 2) then + notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + return + end + subroutine beamn1(notexq,lnote) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,btest, + * isfig,vxtup,isdotm,isbjmp,isbj2,drawbm + common /comoct/ noctup + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*8 noteq + character*79 notexq + ip1 = ipo(jn) + multip = iand(15,mult(ivx,ip1))-8 +c if (multip.le.0 .and. btest(irest(ivx,ip1),0)) then + if (.not.drawbm(ivx) .and. btest(irest(ivx,ip1),0)) then + lnote = 0 +c +c The rest was already written in beamstrt, so just get out of here +c + return + end if + nole = nolev(ivx,ipo(jn)) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ipo(jn)),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ipo(jn)),31)) then + nole = nole + 1 + end if + if (vxtup(ivx) .and. .not.drawbm(ivx)) then +c +c Xtuplet with no beam, just put in the right kind of note +c + if (btest(islur(ivx,ip1),30)) then +c +c Forced stem direction +c + ndsav = nodur(ivx,ip1) + nodur(ivx,ip1) = 2**(4-multip) + if (btest(nacc(ivx,ip1),19) .or. + * btest(nacc(ivx,ip1),27)) nodur(ivx,ip1)=3*nodur(ivx,ip1)/2 + call notex(notexq,lnote) + nodur(ivx,ip1) = ndsav + else + call notefq(noteq,lnoten,nole,ncmid(iv,ip1)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + lnote = 3 + if (multip .eq. 0) then + notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. -1) then + notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 1) then + notexq = sq//'c'//ulq(ivx,ibmcnt(ivx)) + else if (multip .eq. 2) then + notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx)) + lnote = 4 + else if (multip .eq. 3) then + notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx)) + lnote = 5 + else if (multip .eq. -2) then + notexq = sq//'wh' + else if (multip .eq. -3) then + notexq = sq//'breve' + lnote = 6 + else + print* + print*,'(Error in beamn1, send source to Dr. Don)' + call stop1() + end if + if (btest(nacc(ivx,ip1),19) .or. btest(nacc(ivx,ip1),27)) then + notexq = notexq(1:3)//'p' + lnote = 4 + end if + notexq = notexq(1:lnote)//noteq + lnote = lnote+lnoten + end if + return + end if +c +c Check if mult. decreases from 1st note to 2nd +c + if (ibm2(ivx,ibmcnt(ivx)).gt.ip1 + * .or. btest(islur(ivx,ip1),20)) then +c +c More than one note or single-note before a multiplicity-down-up "][" +c + if (btest(islur(ivx,ip1),20)) then + multr = 1 + else if (.not.btest(irest(ivx,ip1+1),0)) then + multr = iand(15,mult(ivx,ip1+1))-8 + else + multr = iand(15,mult(ivx,ip1+2))-8 + end if + lnote = 0 + if (multr .lt. multip) then + do 1 im = multip , multr+1 , -1 + call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) +1 continue + end if + end if +c +c Put in the note +c + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'qb' + else + notexq = sq//'qb' + end if + lnote = lnote+3 +c +c Check for dot +c + isdotm = .false. + if (.not.vxtup(ivx)) then + nd = nodur(ivx,ipo(jn)) + if (nd.ne.0) then + if (2**log2(nd).ne.nd) then + if (.not.btest(iornq(ivx,ip1),13)) then + if (.not.btest(islur(ivx,ip1),3)) then + notexq = notexq(1:lnote)//'p' + else +c +c Double dot +c + notexq = notexq(1:lnote)//'pp' + lnote = lnote+1 + end if + else + notexq = notexq(1:lnote)//'m' + isdotm = .true. + end if + lnote = lnote+1 + end if + end if + else if (btest(nacc(ivx,ip1),19) .or. + * btest(nacc(ivx,ip1),27)) then +c +c In an xtup with special 2:1 notation with a dot on 1st note, or normal dot +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + end if +c +c Do the number; 0 if 12 +c +c 5/25/08 allow >12 +c + if (.not.btest(irest(ivx,ip1),24)) then +c call istring(mod(ivx,12),noteq,len) + call istring(mod(ivx,24),noteq,len) + else +c call istring(mod(ivbj1,12),noteq,len) + call istring(mod(ivbj1,24),noteq,len) + end if + notexq = notexq(1:lnote)//noteq(1:len) + lnote = lnote+len + call notefq(noteq,lnoten,nole,ncmid(iv,ip1)) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (isdotm) then + if (lnoten .eq. 1) then + notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + return + end + subroutine beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + character*79 inameq + logical beamon,firstgulp,figbass,figchk,btest, + * isfig,vxtup,bar1syst,addbrack,flipend,xto,drawbm + common /comeskz2/ eskz2(nm,200) + common /comoct/ noctup + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 +c +c The following is just to save the outputs from SetupB for the case of +c xtups starting with a rest, where beamstrt is called twice. +c + common /comipb/ nnb,sumx,sumy,ipb(24),smed + character*8 noteq + character*79 notexq,tempq + integer nornb(nm),ihornb(nm,24) + real*4 space(80),squez(80) + logical novshrinktop,cstuplet,usexnumt + common /comnvst/ novshrinktop,cstuplet + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + character*10 figq + ibc = ibmcnt(ivx) + ipb1 = ibm1(ivx,ibc) + multb = iand(15,mult(ivx,ipb1))-8 + ip = ipo(jn) +c +c Compute slopes and note offsets from start of beam. Inside SetupB, for each +c xtup in the beam, set eloff,mtupv (in comxtup) for printed number. +c + if (ixrest(ivx).eq.0 .and. .not.btest(nacc(ivx,ip),21)) + * call SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest(ivx)) + if (btest(nacc(ivx,ip),21)) then +c +c This is start of later segment of single-slope beam group so use slope and +c height from prior beam. Slope is already OK. +c + issb(ivx) = issb(ivx)+1 + nolev1(ivx) = lev1ssb(ivx,issb(ivx)) + end if + lnote = 0 + drawbm(ivx) = .true. + if (btest(irest(ivx,ipb1),28) .and. ixrest(ivx).ne.2) then + vxtup(ivx) = .true. + nxtinbm(ivx) = nxtinbm(ivx)+1 +c +c irest(28)=>Xtup starts on this note. Set up for xtuplet. +c Number goes on notehead side at middle note (or gap) of xtup, unless that +c puts it in staff, then it flops to stem (or beam) side. +c __ __ +c | | | O | | +c O | | O +c |___| O |__| | +c +c iud -1 -1 1 1 ...stem direction +c iflop 0 1 -1 0 ...direction of flop +c iup -1 1 -1 1 ...direction of number and bracket +c + iud = 1 + if (ulq(ivx,ibc) .eq. 'u') iud = -1 +c +c Get ip#, note level of middle note (or gap) in xtup +c + ipmid = ipb1+ntupv(ivx,nxtinbm(ivx))/2 + xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud, + * ncmid(iv,ipmid),iand(15,mult(ivx,ipmid))-8) + if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) xnlmid = (xnlmid+ + * levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud, + * ncmid(iv,ipmid-1),iand(15,mult(ivx,ipmid-1))-8))/2 + iflop = 0 + if (abs(xnlmid-ncmid(iv,ipb1)).lt.3.) iflop = -iud + iup = iud+2*iflop + if (btest(irest(ivx,ipb1),14)) then +c +c Alter iud, iflop, iup to flip number/bracket. (Stare at above pic) +c + iup = -iup + iflop = 0 + if (iud*iup .lt. 0) iflop = iup + end if +c +c Determine if a beam is to be drawn +c + do 5 ipp = ibm1(ivx,ibc),ibm2(ivx,ibc) + if (iand(15,mult(ivx,ipp))-8 .le. 0) then + drawbm(ivx) = .false. + go to 6 + end if +5 continue + drawbm(ivx) = .not.btest(islur(ivx,ibm1(ivx,ibc)),18) +6 continue +c +c Are we using tuplet.tex? +c + usexnumt = cstuplet .and. .not.drawbm(ivx) +c +c Place xtup number if needed +c + if (.not.btest(islur(ivx,ipb1),31) .or. multb.le.0) then + mprint = igetbits(nacc(ivx,ip),5,22) + if (mprint.eq.0) mprint=mtupv(ivx,nxtinbm(ivx)) + call putxtn(mprint,iflop,multb,iud,wheadpt, + * poenom,nolev1(ivx),islope(ivx),slfac,xnlmid,islur(ivx,ipb1), + * lnote,notexq,ncmid(iv,ipb1),nlnum,eloff(ivx,nxtinbm(ivx)), + * iup,irest(ivx,ipb1),usexnumt) + end if + if (.not.drawbm(ivx)) then +c +c Xtuplet with no beam +c + if (.not.btest(islur(ivx,ipb1),31)) then +c +c Number printing has not been suppressed, so put in the bracket. +c scale = stretch factor for bracket if there are asx's +c xnsk = length of the bracket in \noteskips = (\elemskips)/(eon) +c + xnsk = (eskz2(ivx,ipb1+ntupv(ivx,nxtinbm(ivx))-1) + * -eskz2(ivx,ipb1))/squez(ib)/feon(space(ib)/squez(ib)) + if (iup .eq. 1) then + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'ovbkt' + else + notexq = sq//'ovbkt' + end if + else + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//sq//'unbkt' + else +c +c Introduced 12/5/98, req'd due to possible presence of in-line TeX +c + notexq = sq//'unbkt' + end if + end if + lnote = lnote+6 + if (iline.eq.1) then + smed = smed/(1.-fracindent) + end if + xslope = 1.8*smed*slfac + islope(ivx) = nint(xslope) + nolev1(ivx) = nlnum - nint(smed*eloff(ivx,1)) + if (islope(ivx) .eq. 0) nolev1(ivx) = nolev1(ivx)-1 + if (iup .eq. 1) nolev1(ivx) = nolev1(ivx)+4 + levbracket = nolev1(ivx) + if (iup.eq.1 .and. cstuplet) levbracket = levbracket-1 + call notefq(noteq,lnoten,levbracket,ncmid(iv,ipb1)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + notexq = notexq(1:lnote)//noteq(1:lnoten)//'{' + lnote = lnote+lnoten+1 + if (xnsk .lt. 0.995) then + write(notexq(lnote+1:lnote+4),'(i1,f3.2)')0,xnsk + lnote = lnote+4 + else if (xnsk .lt. 9.995) then + write(notexq(lnote+1:lnote+4),'(f4.2)')xnsk + lnote = lnote+4 + else + write(notexq(lnote+1:lnote+5),'(f5.2)')xnsk + lnote = lnote+5 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + if (btest(mult(ivx,ipb1),4)) then +c +c Tweak slope of bracket +c + islope(ivx) = islope(ivx)+igetbits(mult(ivx,ipb1),5,5)-16 + end if + if (islope(ivx).lt.0 .or. islope(ivx).ge.10) then + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (islope(ivx) .lt. -9) then + write(notexq(lnote+1:lnote+3),'(i3)')islope(ivx) + lnote = lnote+3 + else + write(notexq(lnote+1:lnote+2),'(i2)')islope(ivx) + lnote = lnote+2 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + else + write(notexq(lnote+1:lnote+1),'(i1)')islope(ivx) + lnote = lnote+1 + end if +c +c Done with bracket +c + end if + if (ixrest(ivx) .eq. 1) then +c +c Put in the rest. Possible problem: Rest is a spacing char, but between +c beamstrt and beamn1 some non-spacing chars. are inserted. +c + if (multb .eq. 0) then + notexq = notexq(1:lnote)//sq//'qp' + lnote = lnote+3 + else if (.not.drawbm(ivx).and.multb.eq.1) then + notexq = notexq(1:lnote)//sq//'ds' + lnote = lnote+3 + else if (.not.drawbm(ivx).and.multb.eq.2) then + notexq = notexq(1:lnote)//sq//'qs' + lnote = lnote+3 + else if (.not.drawbm(ivx).and.multb.eq.3) then + notexq = notexq(1:lnote)//sq//'hs' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//sq//'hpause' + lnote = lnote+7 + end if +c +c No need to come back through this subroutine (as would if rest starts bar +c & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing. +c + ixrest(ivx) = 0 + end if + return + end if +c +c End if block for non-beamed xtup start...note we returned +c + if (ixrest(ivx) .eq. 1) then +c +c Insert rest at start of beamed xtup. See above note for possible problem. +c + nodur(ivx,ipb1) = 2**(4-multb) + call notex(tempq,ltemp) + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//tempq(1:ltemp) + else + notexq = tempq(1:ltemp) + end if + lnote = lnote+ltemp +c +c Re-zero just in case! +c + nodur(ivx,ipb1) = 0 + ibm1(ivx,ibc) = ibm1(ivx,ibc)+1 +c +c See if next note is a non-rest +c + if (.not.btest(irest(ivx,ipb1+1),0)) then + ixrest(ivx) = 2 + else +c +c Suppress reprinting xtup number next time through beamstrt +c + islur(ivx,ipb1+1) = ibset(islur(ivx,ipb1+1),31) +c +c Set new xtup start flag +c + irest(ivx,ipb1+1) = ibset(irest(ivx,ipb1+1),28) + end if + return + end if + end if +c +c Just ended if block for xtups +c + if (vxtup(ivx) .and. ipb1.eq.ibm2(ivx,ibc)) then +c +c Move actual note writing to beamend +c + ixrest(ivx) = 4 + return + end if + if (issb(ivx) .eq. 0) then +c +c 1st bmstrt in single-slope bm grp, Adjust start level(s) and slope if needed +c + iadj = igetbits(ipl(ivx,ipb1),6,11)-30 + if (iadj .ne. -30) then + nolev1(ivx) = nolev1(ivx)+iadj + do 2 isssb = 1 , nssb(ivx) + lev1ssb(ivx,isssb) = lev1ssb(ivx,isssb)+iadj +2 continue + end if + iadj = igetbits(ipl(ivx,ipb1),6,17)-30 + if (iadj .ne. -30) then + islope(ivx) = islope(ivx)+iadj + if (abs(islope(ivx)) .gt. 9) islope(ivx) = sign(9,islope(ivx)) + if (nssb(ivx) .gt. 0) then +c +c Cycle thru non-rest notes in SSBG, looking for bmstrts. +c + isssb = 0 + do 4 inb = 2, nnb + if (btest(nacc(ivx,ipb(inb)),21)) then +c +c Beam segment start. New start level + isssb = isssb+1 + lev1ssb(ivx,isssb) = + * lev1ssb(ivx,isssb)+islope(ivx)*xelsk(inb)/slfac + end if +4 continue + end if + end if + end if + iadj = igetbits(islur(ivx,ipb1),2,27) + addbrack = .false. + if (btest(ipl(ivx,ipb1),30)) then +c +c Check for altered starting polarity. Only in forced beams. Nominal start +c level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.). +c + if (ulq(ivx,ibc).eq.'u' .and. + * nolev1(ivx)+6.lt.nolev(ivx,ipb1)) then + if (lnote .eq. 0) then + notexq = sq//'loff{' + else + notexq = notexq(1:lnote)//sq//'loff{' + end if + lnote = lnote+6 + addbrack = .true. + else if (ulq(ivx,ibc).eq.'l' .and. + * nolev1(ivx)-6.gt.nolev(ivx,ipb1)) then + if (lnote .eq. 0) then + notexq = sq//'roff{' + else + notexq = notexq(1:lnote)//sq//'roff{' + end if + lnote = lnote+6 + addbrack = .true. + end if +c +c Check end level for possible flipping in forced beam. Have to do it +c here since with multiple voices, xelsk will not be preserved. +c + if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then + bmlev = nolev1(ivx)+6+islope(ivx)*xelsk(nnb)/slfac + flipend(ivx) = bmlev.lt.nolev(ivx,ibm2(ivx,ibc)) + else if (ulq(ivx,ibmcnt(ivx)) .eq. 'l') then + bmlev = nolev1(ivx)-6+islope(ivx)*xelsk(nnb)/slfac + flipend(ivx) = bmlev.gt.nolev(ivx,ibm2(ivx,ibc)) + end if + end if + call ntrbbb(multb+iadj,'i',ulq(ivx,ibc),ivx,notexq,lnote) +c +c Put in name of start level and slope, after correcting nolev1 if xtup +c started with a rest. +c + if (ixrest(ivx).eq.2) nolev1(ivx) = + * nint(nolev1(ivx)+xelsk(1)*islope(ivx)/slfac) + call notefq(noteq,lnoten,nolev1(ivx),ncmid(iv,ipb1)) + if (islope(ivx) .lt. 0) then + notexq = notexq(1:lnote)//noteq(1:lnoten)//'{' + lnote = lnote+4+lnoten + write(notexq(lnote-2:lnote),'(i2,a1)')islope(ivx),'}' + else + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+1+lnoten + write(notexq(lnote:lnote),'(i1)')islope(ivx) + end if +c +c Check for beam-thk fine-tuning +c + if (iadj .gt. 0) then + do 1 imp = multb+iadj , multb+1 , -1 + call ntrbbb(imp,'t',ulq(ivx,ibc),ivx,notexq,lnote) +1 continue + end if +c +c If we shifted, must close with right bracket +c + if (addbrack) then + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if +c +c Get 'floor' zmin for figures +c Note: Will not come thru here on 1st note of unbeamed xtup, so figure height +c won't be adjusted. If anyone ever needs that, need to duplicate this +c functionality up above, before exiting. +c + if (figbass .and. (ivx.eq.1 .or. ivx.eq.ivxfig2)) then + if (ivx .eq. 1) then + ivf = 1 + else + ivf = ivxfig2 + end if + zmult = 1.2*(multb-1) + ymin = 100. + do 3 inb = 1, nnb + if (isfig(ivf,ipb(inb))) then + if (ulq(iv,ibc) .eq. 'u') then + ybot = nolev(iv,ipb(inb)) + else + ybot = islope(ivx)/slfac*xelsk(inb)+nolev1(ivx) + * -stemlen-zmult + end if + ymin = min(ymin,ybot) + end if +3 continue + maxdrop = ncmid(iv,ipb1)-4-ymin+5.01 + ifigdr(ivf,iline) = max(ifigdr(ivf,iline),maxdrop) + end if +c +c Compute ornament levels if needed +c + NomOrnLev = ncmid(iv,ipb1)+5 + iorn = 0 + do 8 inb = 1 , nnb + ip = ipb(inb) + if (.not.btest(iornq(ivx,ip),23)) go to 8 + if (btest(irest(ivx,ip),26) .and. ulq(ivx,ibc).eq.'l') then +c +c letter-dynamic or hairpin ending under down-beamed +c + iorn = iorn+1 + ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1 + * -1.2*(multb-1) + ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10) + else if (.not.btest(ipl(ivx,ip),10)) then +c +c Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F +c 15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD +c +c Non-chord. There IS an ornament. Need ihornb only if upbeam, and if +c ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.) +c + if (ulq(ivx,ibc).eq.'u' .and. + * iand(iornq(ivx,ipb(inb)),4163566).gt.0) then + iorn = iorn+1 + iornq(ivx,ip) = ibset(iornq(ivx,ip),22) + ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1 + * +1.2*(multb-1) + ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev) + end if + else +c +c In a chord. Orn may be on main note or non-main or both. Set ihornb if +c upbeam and highest note has orn, or down beam and lowest. Find 1st chord note +c + do 10 icrd1 = 1 , ncrd + if (iand(255,icrdat(icrd1)) .eq. ip .and. + * iand(15,ishft(icrdat(icrd1),-8)) .eq. ivx) go to 11 +10 continue +11 continue +c +c Find outermost note, min or max depending on beam direction ulq. xto is true +c if there's an ornament on that note. Expand orn list to include ._, since if +c on extreme chord note in beam, will move. +c So ornaments are all except 0,4,13 (,g,) +c + levx = nolev(ivx,ip) + xto = iand(iornq(ivx,ipb(inb)),4186094).gt.0 + icrdx = 0 + do 12 icrd = icrd1 , ncrd + if (iand(255,icrdat(icrd)) .ne. ip .or. + * iand(15,ishft(icrdat(icrd),-8)) .ne. ivx) go to 13 + levc = iand(127,ishft(icrdat(icrd),-12)) + if ((ulq(ivx,ibc).eq.'u'.and.levc.gt.levx) .or. + * (ulq(ivx,ibc).eq.'l'.and.levc.lt.levx)) then + levx = levc + icrdx = icrd + xto = iand(icrdorn(icrd),4186094).gt.0 + end if +12 continue +13 continue +c +c If there's orn on extreme note, do stuff +c + if (xto) then + iorn = iorn+1 + if (ulq(ivx,ibc) .eq. 'u') then + ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1 + * +1.2*(multb-1) + ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev) + else + ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1 + * -1.2*(multb-1) + ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10) + end if + if (icrdx .eq. 0) then +c +c Affected ornament is on main note +c + iornq(ivx,ip) = ibset(iornq(ivx,ip),22) + else + icrdorn(icrdx) = ibset(icrdorn(icrdx),22) + end if + end if + end if +8 continue +c +c Henceforth nornb will be a counter. +c + if (iorn .gt. 0) nornb(ivx)=1 + if (ixrest(ivx) .eq. 2) ixrest(ivx) = 0 + return + end + block data + parameter (nm=24) + common /comtol/ tol + common /comtrans/ cheadq + common /compage/ widthpt,ptheight,hoffpt,voffpt, + * nsyst,nflb,ibarflb(0:40), + * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), + * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), + * nistaff(0:40) + common /cblock/ + * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, + * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh + common /cominbot/ inbothd + logical usefig + common /comstart/ facmtr + character*60 cheadq + character*120 instrq,titleq,compoq + logical headlog + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /combmh/ bmhgt,clefend + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + logical kbdrests + common /comkbdrests/ levbotr(8),levtopr(8),kbdrests + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + common /comsize/ isize(nm) +c + data tol /.001/ + data cheadq + * /' '/ + data gslfac /9./ + data instrq,titleq,compoq,headlog /3*' ',.false./ +c +c meter space (pts) = xb4mbr = musicsize*facmtr +c + data facmtr /0.55/ + data grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,clefend,bmhgt + * / 1.3333,.4 , .7 , .3 , 0.2 , 2.0 , 1.0 , + * .7,.7 ,.9 ,.5 ,2.3 ,1.1 / + data rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,arpfac + * / 1.32 , 2.25 , 0.47 , 0.83 , 0.17 , 0.5 , 1.7 / + data rtshfac / 1.0 / + data isize /nm*0/ +c +c From other +c + data ptheight,widthpt,hoffpt,voffpt, + * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, + * xilbn,xilbtc,xilhdr,xilfig,a,b,inbothd,inhnoh + * / 740. , 524. , 0., 0., + * .50 , .25 , 0.4 , 0.4 , 0.2 , 12. ,21. , 12., + * 4 , 1.6 ,5.,5.7,1.071,2.714,16 ,16 / + data fracsys /30*0./ + data ivowg,hoh1,hoh2,hoh2h1 /0,0,0,0,0,1,1,1,1,1,1,1, +c * 2.0,1.5,1.0,0.5,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, + * 2.2,1.7,1.2,0.7,1.3,1.3,0.4,0.8,1.2,0.8,1.2,1.6, + * -2.7,-2.2,-1.7,-1.2,-2.3,-2.1,-1.0,-1.7,-2.1,-1.6,-1.9,-2.3, + * -0.3,0.3 / + data kbdrests /.false./, + * levtopr /9,7,5,5,7,5,6,6/, levbotr /0,0,0,2,1,4,5,4/ + data EarlyTransOn, LaterInstTrans /2*.false./ + data iInstTrans /nm*0/ + end + subroutine catspace(space,squez,nnsk) + parameter (nkb=3999,maxblks=4000) + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /comtol/ tol + logical gotclef + do 16 iptr = nptr(ibarcnt) , nptr(ibarcnt+1)-1 + if (abs(space-durb(iptr)) .lt. tol) then + if (abs(squez-sqzb(iptr)) .lt. tol) then +c +c Increment pre-existing entry +c + nnpd(iptr) = nnpd(iptr)+nnsk + return + end if + end if +16 continue +c +c Didn't find current duration & squez, so add a new entry. +c No particular reason to keep in order, so add at the end. +c + nnpd(nptr(ibarcnt+1)) = nnsk + durb(nptr(ibarcnt+1)) = space + sqzb(nptr(ibarcnt+1)) = squez + nptr(ibarcnt+1) = nptr(ibarcnt+1)+1 + return + end + character*1 function chax(n) +c +c The only reason for this seemingly do-nothing function is to get around an +c apparent bug in the Visual Fortran Standard Edition 5.0.A compiler! +c + chax = char(n) + return + end + subroutine checkdyn(lineq,iccount,ibar) + character*128 lineq + character*1 durq,chax + character*4 dynsymq + logical txtdyn + txtdyn = .false. +c +c On entry, iccount is on "D" +c + if (lineq(iccount+1:iccount+1) .eq. '"') then +c +c Dynamic text +c + iend = index(lineq(iccount+2:128),'"') + if (iend .eq. 0) then + call errmsg(lineq,iccount+1,ibar, + * 'Dynamic text must be terminated with double quote!') + call stop1() + end if +c +c Set iccount to character after 2nd ", and set ipm +c + iccount = iccount+iend+2 + ipm = index('- +',lineq(iccount:iccount)) + if (ipm .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected "-", "+", or blank here!') + call stop1() + end if + else +c +c Expect ordinary dynamic +c + do 1 iend = iccount+2 , 128 + ipm = index('- +',lineq(iend:iend)) + if (ipm .gt. 0) go to 2 +1 continue +2 continue + if (iend-iccount.gt.5 .or. iend-iccount.lt.2) then + call errmsg(lineq,iend-1,ibar, + * 'Wrong length for dynamic mark!') + call stop1() + end if + read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')') + * dynsymq + idno = (index( + * 'ppppppp pp p mp mf f fp sfz ff fff ffff< > ', + * dynsymq)+3)/4 + if (idno .eq. 0) then + call errmsg(lineq,iccount+1,ibar,'Illegal dynamic mark!') + call stop1() + end if + iccount = iend + end if + if (ipm .ne. 2) then +c +c There is a vertical shift, have "+" or "-" +c + iccount = iccount+1 + if (index('0123456789',lineq(iccount:iccount)) .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected integer here for vertical offset!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + idno = nint(fnum) + if (idno .gt. 63) then + call errmsg(lineq,iccount-1,ibar, + * 'Vertical offset for dynamic mark must be (-63,63)!') + call stop1() + end if + ipm = index('- +',durq) + if (ipm .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected "+", "-", or blank here!') + call stop1() + end if + if (ipm .ne. 2) then +c +c There is a horizontal shift +c + iccount = iccount+1 + if (index('.0123456789',lineq(iccount:iccount)) .eq. 0) then + call errmsg(lineq,iccount,ibar, + * 'Expected number here for horizontal offset!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + idno = nint(10*fnum) + if (idno .gt. 255) then + call errmsg(lineq,iccount-1,ibar, + * 'Horizontal offset for dynamic mark must be (-25.5,25.5)!') + call stop1() + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibar, + * 'There should be a blank here!') + call stop1() + end if + end if +c +c iccount should be on the blank at the end of the entire symbol +c + end if + return + end + subroutine chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp) +c subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp, +c * icashft) + logical found1,iscacc,isarp,btest + integer icrdat(193) + found1 = .false. +c +c icashft will be max left shift of accid's in chord notes. +c Used only for spacing checks. +c Will include left shift of chord note itself. +c Rezero after use. +c + do 18 icrd = 1 , ncrd +c +c This if block cycles thru all chord notes on ivx,ip; then returns. +c + if (iand(255,icrdat(icrd)) .eq. ip .and. + * iand(15,ishft(icrdat(icrd),-8)) .eq. ivx) then + found1 = .true. + iscacc = iscacc .or. + * (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) +c +c Accid on this chord note, and it's not midi-only. +c +c irshft = igetbits(icrdot(icrd),7,20) +cc +cc Include increment for notehead shift +cc +c if (btest(icrdat(icrd),23)) then +c if (irshft .eq. 0) then +c irshft = 44 +c else +c irshft=irshft-20 +c end if +c end if +c if (irshft .ne. 0) then +cc +cc Accid on chord note is shifted. Include only left shift, in 20ths. +cc +c if (irshft .lt. 64) icashft = max(icashft,64-irshft) +c end if +c end if + isarp = isarp .or. btest(icrdat(icrd),25) + else if (found1) then + return + end if +18 continue + return + end + subroutine chkimidi(icm) + parameter (nm=24,mv=24576) + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + if (imidi(icm) .ge. mv) then + print* + print*,'Midi file is too long! It will be corrupted or worse' + write(*,'(a6,2x,4i8)') + * 'imidi:',imidi(0),imidi(1),imidi(2),imidi(3) + end if + return + end + subroutine chklit(lineq,iccount,literr) + character*128 lineq + character*1 charq,chax + literr = 0 + itype = 1 +17 call g1etchar(lineq,iccount,charq) + if (charq .eq. chax(92)) then + itype = itype+1 +c if (itype .eq. 2) then +c if (iccount .ne. 2 ) then +cc +cc type 2 or 3 tex string not starting in column 1 +cc +c literr = 3 +c return +c end if +c else if (itype .gt. 3) then + if (itype .gt. 3) then + literr = 1 + return + end if + go to 17 + end if + lenlit = itype +18 call g1etchar(lineq,iccount,charq) + if (charq.eq.chax(92)) then + call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') then +c +c Starting a new tex command withing the string +c + lenlit = lenlit+2 + if (lenlit .gt. 128) then + literr = 2 + return + end if + go to 18 + end if + else + lenlit = lenlit+1 + if (lenlit .gt. 128) then + literr = 2 + return + end if + go to 18 + end if + return + end + subroutine chkpm4ac(lineq,iccount,nacc,moved) +c +c Called after getting +/-/</> in a note (not rest). iccount is on the +-<>. +c Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits +c 10-16) if < or >, horiz and vert (bits 4-9) if two consecutive signed +c numbers. If moved=.true., iccount on exit is on end of last number. +c If moved=.false., iccount still on +/- +c + logical moved,ishorz + character*128 lineq + character*1 durq + if (index('sfnA',lineq(iccount-1:iccount-1)).gt.0 .and. + * index('0123456789.',lineq(iccount+1:iccount+1)).gt.0) then +c +c Prior char was accid & next is #; this may be start of accidental shift. +c Must test for "." above in case we get "<" or ">" +c + ipm = index('- +< >',lineq(iccount:iccount))-2 + if (lineq(iccount+1:iccount+1).eq.'.' .and. + * index('0123456789',lineq(iccount+2:iccount+2)).eq.0) then +c +c Rare case of [accid][+/-].[letter]. Bail out +c + moved = .false. + return + end if + ishorz = ipm .gt. 1 +c +c Save iccount in case it's not accid shift and we have to reset. +c + icsav = iccount + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (ishorz .or. index('+-',durq).gt.0) then +c +c This has to be accidental shift. Set vert. shift. +c + if (.not.ishorz) then +c +c +/- syntax, both shifts set, vertical first +c + call setbits(nacc,6,4,int(ipm*fnum+32.5)) + ipm = index('- +',durq)-2 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + else +c +c </> syntax, only horiz set +c + ipm = ipm-3 + end if +c +c Set horiz. shift +c + call setbits(nacc,7,10,nint(20*(ipm*fnum+5.35))) + iccount = iccount-1 + moved = .true. + else +c +c False alarm. Reset everything and flow onward +c + moved = .false. + iccount = icsav + end if + else +c +c Either prior char was not 'sfn' or next was not digit, so take no action +c + moved = .false. + end if + return + end + subroutine clefsym(isl,notexq,lnote,nclef) +c +c Returns string calling Don's TeX macro \pmxclef, for drawing small clefs. +c + character*(*) notexq + character*1 chax + nclef = iand(ishft(isl,-12),7) + if (nclef .eq. 0) then +c +c treble +c + nlev = 2 + else if (nclef .gt. 6) then +c +c French violin +c + nlev = 0 + else if (nclef .lt. 5) then +c +c C-clef +c + nlev = 2*nclef-2 + else +c +c F-clef +c + nlev = 2*nclef-6 + end if + notexq = chax(92)//'pmxclef'//chax(48+min(nclef,7)) + * //chax(48+nlev) + lnote = 10 + return + end + subroutine crdacc(nacc,naccid,micrd,nolevm,rmsshift,lasttime, + * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) +c +c nacc = accidental bitmap for main note +c naccid = # of accid's in chord +c micrd = array with icrd #'s for notes w/ acc's, 0=>main note +c nolevm = level of main note +c segrb(1|2,.) x|y-coord of right-bdry segment +c ksegrb(.) internal use; tells what defined this segment +c -2: Left-shifted notehead +c -1: Original right boundary +c 0: Main note accidental +c icrd: Chord-note accidental +c isetshft(i),i=1,naccid: what set shift for this accid, same codes +c icrdot0 = top-down level-rank of main note among accid-notes +c icrdot(icrd)(27-29) = level rank of chord-note among accid-notes +c twooftwo will be true 2nd time thru; signal to store shifts w/ notes +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + real*4 segar(5,2,6),segal(5,2,6),segrb(2,50),segrb0(2,50) + integer*4 nsegar(5),nsegal(5),micrd(10),iacctbl(6),ksegrb(50), + * isetshft(10),ksegrb0(50) + logical lasttime,mainnote,twooftwo + data nsegar / 3,4,3,3,2 /, nsegal / 2,4,3,3,2 / + data segar / +c +c Fancy sharp boundary. fl,sh,na,dfl,dsh +c + * -0.05,-0.38,-0.34,-.05, -.15,-1.4,-2.9,-3.0, -1.4, -1.2, +c * -0.75,-0.20,-0.80, 0. , 0. , .96,-1.04,1.6, 0. , 0. , +c meas value for y, natural is 1.6 + * -0.75,-0.20,-0.80,-.75, 0. , .96,-1.04,1.48, .96, 1.2, + * 0.00,-0.38, 0.00, 0. , 0. ,3.15, 1.64,3.0, 3.15, 0. , + * 0. , 0.00, 0. , 0. , 0. , 0. , 2.90, 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. / + data segal / +c * 0.00, 0.00,-1.04, 0. , 0. ,3.15, 2.9,-1.6, 0. , 0. , +cc (meas. value is 3.08) ^^^^ +cc Raise top of flat so it interferes with bottom of sharp + * -1.00,-1.02,-0.60,-1.65, -1.2,-1.4,-2.9, -3.0, -1.4, -1.2, + * 0.00,-1.20,-1.04, 0. , 0. ,3.15,-1.64,-1.48,3.15, 1.2, + * 0. ,-1.02, 0.00, 0. , 0. , 0. , 1.04, 3.0, 0. , 0. , + * 0. , 0.00, 0. , 0. , 0. , 0. , 2.9 , 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , + * 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. , 0. / +c +c iacctbl(i) = internal accid # (1-5) when i=extern accid # (1,2,3,5,6) +c + data iacctbl / 1 , 2 , 3 , 0 , 4 , 5 / +c +c Set up barrier segrb(iseg,ipoint) to define coords of corner points +c on stem+notes +c + do 11 iseg = 1 , nsegrb0 + segrb(1,iseg) = segrb0(1,iseg) + segrb(2,iseg) = segrb0(2,iseg) + ksegrb(iseg) = ksegrb0(iseg) +11 continue + nsegrb = nsegrb0 + rmsshift = 0. + shiftmin = 1000. + do 1 iwa = 1 , naccid +c +c Initialize shift for this note +c + shift = 0. + mainnote = micrd(iwa).eq.0 + isetshft(iwa) = -1 +c +c Get note level and accidental type +c + if (mainnote) then + nolev = nolevm + iacctype = iacctbl(igetbits(nacc,3,0)) + else + nolev = igetbits(icrdat(micrd(iwa)),7,12) + iacctype = iacctbl(igetbits(icrdat(micrd(iwa)),3,20)) + end if +c +c Cycle thru segments on right edge of this accidental +c + do 2 isega = 1 , nsegar(iacctype)-1 + ybotaseg = nolev+segar(iacctype,2,isega) + ytopaseg = nolev+segar(iacctype,2,isega+1) +c +c Cycle thru segments of right-hand barrier +c + do 3 isegrb = 1 , nsegrb-1 +c +c Must find all barrier segments that start below ytopseg & end above ybotseg +c + if (segrb(2,isegrb) .lt. ytopaseg) then +c +c Barrier seg starts below top of accid +c Check if barrier seg ends above bottom of accid +c + if (segrb(2,isegrb+1) .gt. ybotaseg) then + if (shift .gt. + * segrb(1,isegrb)-segar(iacctype,1,isega)) then + shift = segrb(1,isegrb)-segar(iacctype,1,isega) +c +c Record the cause of the shift +c + isetshft(iwa) = ksegrb(isegrb) + end if + end if +c +c Does barrier segment end above top of accid seg? +c + if (segrb(2,isegrb+1) .gt. ytopaseg) go to 4 + end if +3 continue +4 continue +2 continue + if (.not.btest(nacc,28) .and. abs(shift).gt.0.0001 + * .and. .not.lasttime) then +c if (nolev .eq. levmaxacc) then + if (nolev.eq.levmaxacc .and. isetshft(iwa).eq.-1) then + rmsshift = 1000. + return + end if +c +c Does the following properly account for left-shifted noteheads? +c +c Top-down rank of this note we just shifted +c + if (mainnote) then + irank = icrdot0 + else + irank = igetbits(icrdot(micrd(iwa)),3,27) + end if +c +c Compare level-rank of this note vs. that of note that caused the shift. +c This has effect of checking for basic interferences from top down. +c +c ksegrb(.) internal use; tells what defined this segment +c -2: Left-shifted notehead +c -1: Original right boundary +c 0: Main note accidental +c icrd: Chord-note accidental +c isetshft(i),i=1,naccid: what set shift for this accid, same codes +c + if (isetshft(iwa) .lt. 0) then + iranksetter = 0 + else if (isetshft(iwa) .eq. 0) then + iranksetter = icrdot0 + else + iranksetter = igetbits(icrdot(isetshft(iwa)),3,27) + end if + if (iranksetter.ne.0 .and. irank.ne.iranksetter+1) then + rmsshift = 1000. + return + end if + end if + rmsshift = rmsshift+shift**2 + if (lasttime .and. abs(shift).gt..0001) then + if (mainnote) then + if (.not.btest(nacc,29)) go to 10 + else + if (.not.btest(icrdat(micrd(iwa)),29)) go to 10 + end if +c +c If here, "A" was set on a manual shift, so must cumulate the shift. Note that if there +c was a manual shift but auto-shift was zero, will not come thru here, but shift value +c will be left intact. +c + if (mainnote) then + shift = shift+.05*(igetbits(nacc,7,10)-107) + else + shift = shift+.05*(igetbits(icrdot(micrd(iwa)),7,20)-107) + end if +10 continue + if (twooftwo) then +c +c Record the shift for this accidental +c + if (shift .lt. -5.35) then + call printl(' ') + call printl('WARNING: auto-generated accidental '// + * 'shift too big for PMX, ignoring') + else + ishift = nint(20*(shift+5.35)) + if (mainnote) then + call setbits(nacc,7,10,ishift) + else + call setbits(icrdot(micrd(iwa)),7,20,ishift) + end if + end if + else +c +c This is the earlier call to precrd, so need minimum shift +c + shiftmin = min(shiftmin,shift) + end if + end if +c +c Bail out if this is the last accidental to check +c + if (iwa .eq. naccid) go to 1 +c +c Add this accidental to the right barrier! Count down from highest barrier segment, +c find 1st one starting below top of accid, and first one starting below bot. +c + do 5 ibelowtop = nsegrb , 1 , -1 + if (segrb(2,ibelowtop) .lt. + * nolev+segal(iacctype,2,nsegal(iacctype))) then + do 9 ibelowbot = ibelowtop , 1 , -1 + if (segrb(2,ibelowbot) .lt. + * nolev+segal(iacctype,2,1)) go to 6 +9 continue + print*,'Oops2!' + call stop1() + end if +5 continue + print*,'Ugh0! in crdaccs' + call stop1() +6 continue + netgain = nsegal(iacctype)-ibelowtop+ibelowbot +c +c Shift high segments up +c + if (netgain .ge. 0) then + do 7 isegrb = nsegrb , ibelowtop+1 , -1 + segrb(1,isegrb+netgain) = segrb(1,isegrb) + segrb(2,isegrb+netgain) = segrb(2,isegrb) + ksegrb(isegrb+netgain) = ksegrb(isegrb) +7 continue +c +c Set up 1st segment above accid +c + segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop) + segrb(2,ibelowtop+netgain) = + * nolev+segal(iacctype,2,nsegal(iacctype)) + ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop) + else +c +c netgain<0, must remove segments. Use same coding but reverse order, +c work from bottom up +c + segrb(1,ibelowtop+netgain) = segrb(1,ibelowtop) + segrb(2,ibelowtop+netgain) = + * nolev+segal(iacctype,2,nsegal(iacctype)) + ksegrb(ibelowtop+netgain) = ksegrb(ibelowtop) + do 12 isegrb = ibelowtop+1 , nsegrb + segrb(1,isegrb+netgain) = segrb(1,isegrb) + segrb(2,isegrb+netgain) = segrb(2,isegrb) + ksegrb(isegrb+netgain) = ksegrb(isegrb) +12 continue + end if +c +c Insert new segments +c + do 8 isega = 1 , nsegal(iacctype)-1 + segrb(1,ibelowbot+isega) = shift+segal(iacctype,1,isega) + segrb(2,ibelowbot+isega) = nolev+segal(iacctype,2,isega) + if (mainnote) then + ksegrb(ibelowbot+isega) = 0 + else + ksegrb(ibelowbot+isega) = micrd(iwa) + end if +8 continue +c +c Update number of barrier segments +c + nsegrb = nsegrb+netgain +cc +cc Temporary printout for boundary segments as built up +cc +c write(15,'()') +c write(15,'(a/(2f8.2,i5))')' y x kseg', +c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) +c write(15,'(a/(2i5))')' micrd isetshft', +c * (micrd(iwa1),isetshft(iwa1),iwa1=1,iwa) +cc +1 continue ! next accidental + if (lasttime .and. .not.twooftwo) then +c +c This is the final call on the pre-ask pass, so compute left-shift rqmt. +c + icashft = nint(-20*shiftmin) + end if +cc +cc Temporary printout for boundary segments +cc +c if (twooftwo) then +c write(15,'()') +c write(15,'(a/(2f8.2,i5))')' y x kseg', +c * (segrb(2,iseg),segrb(1,iseg),ksegrb(iseg),iseg=1,nsegrb) +c write(15,'(a/(2i5))')' micrd isetshft', +c * (micrd(iwa),isetshft(iwa),iwa=1,naccid) +c end if +cc + return + end + subroutine crdaccs(nacc,ipl,irest,naccid,kicrd,nolevm, + * levmaxacc,levminacc,icrdot0,twooftwo,icashft) +c +c nacc = accidental bitmap for main note +c naccid = # of accid's in chord +c kicrd = array with icrd #'s for notes w/ acc's, 0=>main note +c nolevm = level of main note +c +c This is called once per multi-accidental chord. In here, loop over all +c permutations of the order of accidental as stored in kicrd. Each time thru +c loop, call crdacc once, get rms shift. Only save permutation and rms value +c if it is less than old value. +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 +c +c Make consistent? 120106 +c integer*4 kicrd(7),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) + integer*4 kicrd(10),iperm(7),micrd(10),ipermsav(7),ksegrb0(50) + real*4 segrb0(2,50) + logical btest,tagged,manual,lshift,twooftwo +cc +cc Temporary printout of level-rankings +cc +c write(15,'()') +c do 98 iacc = 1 , naccid +c if (kicrd(iacc) .eq. 0) then +c write(15,'(3i5)')nolevm,icrdot0 +c else +c write(15,'(2i5)')igetbits(icrdat(kicrd(iacc)),7,12), +c * igetbits(icrdot(kicrd(iacc)),3,27) +c end if +c98 continue +cc +c +c Initialize right-barrier +c + segrb0(1,1) = 0. + segrb0(2,1) = -1000. + segrb0(1,2) = 0. + segrb0(2,2) = 1000. + nsegrb0 = 2 + ksegrb0(1) = -1 + ksegrb0(2) = -1 +c +c Search for left-shifted notes, Make up the initial right-barrier, which +c will be good for all permutations. +c irest()(27) is set if any notes are left-shifted +c Must use ALL chord notes, not just ones w/ accid's. +c + if (btest(irest,27)) then + do 15 icrd = icrd1-1, icrd2 + if (icrd .eq. icrd1-1) then +c +c Main note +c +c lshift = btest(ipl,8) + lshift = btest(ipl,8) .or. btest(nacc,31) + if (lshift) nolev = nolevm + else +c +c Chord note +c + lshift = btest(icrdat(icrd),23) +c if (lshift) nolev = igetbits(icrdat(icrd),7,12) + if (lshift) then + nolev = igetbits(icrdat(icrd),7,12) + if (btest(nacc,31) .and. nolev.eq.nolevm+1) then +c +c This note is not really shifted, It is the upper of a 2nd with the main +c note on an upstem, and Main note must be shifted. +c nacc(31) signals the real truth. +c + lshift = .false. + end if + end if + end if + if (lshift) then + do 16 isegrb = 1 , nsegrb0-1 + if (segrb0(2,isegrb+1) .gt. nolev-1) then +c +c Add this notehead to the right boundary here. Move all higher segs up 2. +c + do 17 iiseg = nsegrb0 , isegrb+1 , -1 + segrb0(1,iiseg+2) = segrb0(1,iiseg) + segrb0(2,iiseg+2) = segrb0(2,iiseg) + ksegrb0(iiseg+2) = ksegrb0(iiseg) +17 continue + go to 18 + end if +16 continue +18 continue +c +c Insert notehead into list. Set kseg=-2 to signal notehead shift. +c + iiseg = isegrb+1 + segrb0(1,iiseg) = -1.2 + segrb0(2,iiseg) = nolev-1. + ksegrb0(iiseg) = -2 + segrb0(1,iiseg+1) = 0. + segrb0(2,iiseg+1) = nolev+1. + ksegrb0(iiseg+1) = -1 + nsegrb0 = nsegrb0+2 + end if +15 continue + end if +c +c Done setting right barrier for left-shifted noteheads +c + tagged = .false. + manual = .false. +c +c Preprocess to check for manual shifts. +c If are manual main [nacc(10-16)] or chord note [icrdot(20-26)]shifts, then +c If any manual shift is preceded by "A" [nacc(29), icrdat(29)] then +c 1. Auto-shifting proceeds +c 2. "A"-shifts add to autoshifts +c 3. non-"A" shifts are ignored! +c Else (>0 man shifts, none has "A") +c No auto-ordering, No autoshifts, Observe all manual shifts. +c End if +c End if +c + maxmanshft = 0 + do 13 i = 1 , naccid + if (kicrd(i) .eq. 0) then +c +c Main note +c + manshft = igetbits(nacc,7,10) + if (manshft .ne. 0) then + manual = .true. + if (btest(nacc,29)) then + tagged = .true. + else +c maxmanshft = max(maxmanshft,64-manshft) + maxmanshft = max(maxmanshft,107-manshft) + end if + end if + else +c +c Chord note +c + manshft = igetbits(icrdot(kicrd(i)),7,20) + if (manshft .ne. 0) then + manual = .true. + if (btest(icrdat(kicrd(i)),29)) then + tagged = .true. + else +c maxmanshft = max(maxmanshft,64-manshft) + maxmanshft = max(maxmanshft,107-manshft) + end if + end if + end if +13 continue + if (manual) then + if (tagged) then +c +c zero out all untagged shifts +c + do 14 i = 1 , naccid + if (kicrd(i) .eq. 0) then + if (.not.btest(nacc,29)) call setbits (nacc,7,10,0) + else + if (.not.btest(icrdat(kicrd(i)),29)) + * call setbits (icrdot(kicrd(i)),7,20,0) + end if +14 continue + else +c +c There are manual shifts but none tagged. Only proceed if "Ao" was entered +c + if (.not.btest(nacc,28)) then + icashft = maxmanshft + return + end if + end if + end if + if (btest(nacc,28)) then +c +c Take the accidentals in order as originally input, then exit. +c + call crdacc(nacc,naccid,kicrd,nolevm,rmsshift,.true., + * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) + return +c end if + else if (naccid .eq. 3) then +c +c Special treatment if 3 accidentals in chord. If there aren't accids on a 2nd +c then place in order top, bottom, middle. +c + do 20 i = 1 , 3 + if (kicrd(i) .eq. 0) then + irank = icrdot0 + nolev = nolevm + else + irank = igetbits(icrdot(kicrd(i)),3,27) + nolev = igetbits(icrdat(kicrd(i)),7,12) + end if + if (irank .eq. 1 ) then + micrd(1) = kicrd(i) + else + micrd(5-irank) = kicrd(i) + end if + if (irank .eq. 2) then + levmidacc = nolev + end if +20 continue + if (levmaxacc.ne.levmidacc+1 .and. + * levmidacc.ne.levminacc+1) then + call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true., + * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) + return + end if + end if + rmsmin = 100000. +c +c Initialize permutation array +c + do 7 i = 1 , naccid + iperm(i) = i +7 continue +c +c Start looping over permutations +c + do 8 ip = 1 , 5041 + if (ip .ne. 1) then +c +c Work the magic algorithm to get the next permutation +c + do 1 k = naccid-1 , 1 , -1 + if (iperm(k) .le. iperm(k+1)) go to 2 +1 continue +c +c If here, we just got the last permutation, so exit the loop over permutations +c + go to 10 +2 continue + do 3 j = naccid , 1 , -1 + if (iperm(k) .le. iperm(j)) go to 4 +3 continue +4 continue + it = iperm(j) + iperm(j) = iperm(k) + iperm(k) = it + is = k+1 + do 5 ir = naccid , 1 , -1 + if (ir .le. is) go to 6 + it = iperm(ir) + iperm(ir) = iperm(is) + iperm(is) = it + is = is+1 +5 continue +6 continue + end if +c +c New we have a permutation. Take icrd values out of kicrd and put them into +c micrd in the order of the permutation +c + do 9 i = 1 , naccid + micrd(i) = kicrd(iperm(i)) +9 continue +cc +cc Temporary printout +cc +c write(15,'(/a6,10i3)')'perm:',(iperm(i),i=1,naccid) +cc + call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.false., + * levmaxacc,icrdot0,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) +cc +cc Temporary printout +cc +c write(15,*)'perm done, rmsshift:',rmsshift +cc + if (rmsshift .lt. rmsmin) then +c +c Save this permutation, reset minrms +c + do 11 i = 1 , naccid + ipermsav(i) = iperm(i) + rmsmin = rmsshift +11 continue + end if +8 continue + print*,'Should not BEEEEEE here!' + call stop1() +10 continue +c +c Done looping, get info for the final choice +c + do 12 i = 1 , naccid + micrd(i) = kicrd(ipermsav(i)) +12 continue +cc +cc Temporary printout +cc +c write(15,'(/a6,10i3)')'Final perm:',(ipermsav(i),i=1,naccid) +cc + call crdacc(nacc,naccid,micrd,nolevm,rmsshift,.true., + * idummy,idummy,segrb0,ksegrb0,nsegrb0,twooftwo,icashft) + return + end + subroutine doacc(ihshft,ivshft,notexq,lnote,nacc,nolev,ncm,caut) + character*1 sq,chax + character*3 acsymq + character*8 noteq + character*79 notexq + logical btest,caut + sq = chax(92) + if (ihshft .eq. -107) ihshft=0 +cc +cc If main note shifted left, so shift accid. Terminate below, when acc. is done. +cc + if (ihshft .ne. 0) then +c +c Accid must be shifted horizontally +c + if (ihshft .lt. 0) then + notexq = sq//'loffset{' + ihshft = -ihshft + else + notexq = sq//'roffset{' + end if + hshft = .05*ihshft + if (hshft .lt. 1.) then + write(notexq(10:12),'(f3.2)')hshft + lnote = 12 + else + write(notexq(10:13),'(f4.2)')hshft + lnote = 13 + end if + notexq = notexq(1:lnote)//'}{'//sq + lnote = lnote+3 + else + notexq = sq + lnote = 1 + end if + if (btest(nacc,3)) then + notexq = notexq(1:lnote)//'big' + lnote = lnote+3 + end if + if (caut) then +c +c Cautionary accidental. Need to define bigcna,... in pmx.tex +c + notexq = notexq(1:lnote)//'c' + lnote = lnote+1 + end if + call accsym(nacc,acsymq,lacc) + notexq = notexq(1:lnote)//acsymq(1:lacc) + lnote = lnote+lacc + noleva = nolev + if (ivshft .ne. 0) noleva = noleva+ivshft-32 + call notefq(noteq,lnoten,noleva,ncm) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (ihshft .ne. 0) then +c +c Terminate horizontal shift +c + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + return + end + subroutine docrd(ivx,ip,nodu,ncm,iv,tnow,soutq,lsout,ulq,ibmcnt, + * islur,nvmx,nv,beamon,nolevm,ihornb,nornb,stemlen, + * dotxtup,nacc) + parameter (nm=24,mv=24576) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + logical lowdot,dotxtup + integer*4 ihornb(nm,24),nornb(nm) + character*1 ulq(nm,9),chax + character*7 nosymq + character*8 noteq + character*79 notexq,outq + character*80 soutq + logical btest,isleft,isright,beamon + character*79 inameq + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) +c + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans +c +c +c This subr. once produced notexq for entire chord. 10/18/97 altered to write +c chord notes as we go. 10/22/97 find range of icrd first. +c 2/25/98 moved rangefinding to precrd so done before slurs, so now +c on entry, icrd1, icrd2 define range of icrd for this chord. +c +c Set counter (for this note) for chord notes present. Set notmain=T. +c Will test for notmain=.true. in addmidi to tell whether to save pitch. +c + nmidcrd = 0 + notmain = .true. + crdacc = .false. + do 5 icrd = icrd1 , icrd2 + lnote = 0 + nolev = igetbits(icrdat(icrd),7,12) +c +c 3/8/03 save original pitch to use in midi, in case 2nds alter things. +c + nolevo = nolev +c +c Check for special situations with 2nds (see precrd). +c + if (btest(nacc,30)) then + if (nolev .eq. nolevm-1) nolev = nolevm + else if (btest(nacc,31)) then + if (nolev .eq. nolevm+1) nolev = nolevm + end if +c +c Lower dot for lower-voice notes?. Conditions are: +c 1. Dotted time value +c 2. Lower voice of two +c 3. Note is on a line +c 4. Not a rest (cannot be a rest in a chord!) +c. 5. Flag (lowdot) is set to true +c + if (lowdot .and. nvmx.eq.2 .and. ivx.le.nv) then + if (2**log2(nodu).ne.nodu .and. mod(nolev-ncm,2).eq.0) then + if (btest(icrdat(icrd),26)) then +c +c Note already in movdot list. Drop by 2. +c + call setbits(icrdot(icrd),7,0, + * igetbits(icrdot(icrd),7,0)-20) + else +c +c Not in list so just move it right now +c + call dotmov(-2.,0.,soutq,lsout,igetbits(islur,1,3)) + end if + end if + end if + if (btest(icrdat(icrd),26)) then +c +c Move the dot. +c + updotc = 0.1*(iand(127,icrdot(icrd))-64) + rtdotc = 0.1*(iand(127,ishft(icrdot(icrd),-7))-64) + call dotmov(updotc,rtdotc,soutq,lsout,igetbits(islur,1,3)) + end if + isleft = btest(icrdat(icrd),23) + isright = btest(icrdat(icrd),24) +c +c Check for ornament in chord. +c + if (icrdorn(icrd) .gt. 0) then + call putorn(icrdorn(icrd),nolev,nolevm,nodu,nornb,ulq, + * ibmcnt,ivx,ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout, + * ip,0,beamon,.true.) +c +c subroutin putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx, +c * ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,ip,islhgt, +c * notcrd,beamon,iscrd) +c + call addstr(outq,lout,soutq,lsout) + end if +c +c Chord-note symbol. First check for breve +c + if (nodu .eq. 128) then + nosymq = chax(92)//'zbreve' + lsym = 7 + else +c +c Not a breve chord. Get first letters in chord-note symbol +c + if (isleft) then + nosymq = chax(92)//'l' + else if (isright) then + nosymq = chax(92)//'r' + else + nosymq = chax(92)//'z' + end if + if (nodu .ge. 64) then + nosymq = nosymq(1:2)//'w' + else if (nodu .ge. 32) then + nosymq = nosymq(1:2)//'h' + else + nosymq = nosymq(1:2)//'q' + end if + if (2**log2(nodu).eq.nodu .and. .not.dotxtup) then + lsym = 3 + else if (.not.btest(islur,3) .or. dotxtup) then +c +c Single dot +c + nosymq = nosymq(1:3)//'p' + lsym = 4 + else +c +c Double dot +c + nosymq = nosymq(1:3)//'pp' + lsym = 5 + end if + end if + if (btest(icrdat(icrd),19).and..not.btest(icrdat(icrd),27)) then +c +c Accidental and not MIDI-only. Build up bits 0-3 of nacc +c + nactmp = igetbits(icrdat(icrd),3,20) +c +c Kluge for bigness. Only means 'As' has not been issued +c + if (bacfac .ne. 1.e6) nactmp = nactmp+8 + call doacc(igetbits(icrdot(icrd),7,20)-107, + * igetbits(icrdot(icrd),6,14), +c * notexq,lnote,nactmp,nolev,ncmid(iv,ip)) +c Get original nolev, not altered to deal with 2nds + * notexq,lnote,nactmp,igetbits(icrdat(icrd),7,12), +c * ncmid(iv,ip)) + * ncmid(iv,ip),btest(icrdat(icrd),31)) + notexq = notexq(1:lnote)//nosymq + crdacc = .true. + else + notexq = nosymq + end if + lnote = lnote+lsym +c +c Get note name (again if accid, due to possible octave jump) +c + call notefq(noteq,lnoten,nolev,ncm) + if (lnoten.eq.1) call addblank(noteq,lnoten) +c +c Put in note name +c + notexq = notexq(1:lnote)//noteq + lnote = lnote+lnoten + if (btest(icrdat(icrd),25)) then +c +c Arpeggio signal +c +c call putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) + call putarp(tnow,ivx,ip,nolev,ncm,soutq,lsout) + end if + call addstr(notexq,lnote,soutq,lsout) + if (ismidi) then +c +c Here is where we collect MIDI pitch info for the chord note. By checking +c notmain, addmidi(...) knows to just compute the +c pitch number and store it in mcpitch(nmidcrd). Then on call to addmidi() +c for MAIN note, will put in note codes for all chord notes + main note. +c + kv = 1 + if (ivx .gt. iv) kv=2 + nmidcrd = nmidcrd+1 + if (nmidcrd .gt. 20) then + print* + print*,'21 chord notes is too many for midi processor' + call stop1() + end if +c +c Use original saved pitch level, unaltered by 2nds logic. +c +c call addmidi(midchan(iv,kv),nolevo, + call addmidi(midchan(iv,kv),nolevo-iTransAmt(instno(iv)), + * igetbits(icrdat(icrd),3,20),isig,1.,.false.,.false.) + end if +5 continue + notmain = .false. + return + end + subroutine dodyn(ivx,ip,nolev,ncm,ipl,islur,irest,nvmx,nv, + * beamon,ihornb,nornb,ulq,ibmcnt,nostem,soutq,lsout) + parameter (nm=24) +c +c Inputs are array *elements* except ihornb,nornb,ulq +c + common /commus/ musize,whead20 + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + logical btest,beamon,upstem,nostem + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical fontslur,upslur,WrotePsslurDefaults + character*1 udqq,chax,ulq(nm,9) + character*4 dynstrq + character*5 numpq + character*48 dyntablq,tempq + character*79 notexq + character*80 soutq + integer*4 ihornb(nm,24),nornb(nm),idynn(10) + data dyntablq /'ppppppp pp p mp mf f fp sfz ff fff ffff'/ + numdyn = 0 +c +c Find dynamics for (ivx,ip) in list. May be as many as 4. Store idyn values +c in idynn(1...4) +c + do 1 idyn = 1 , ndyn +c ivxtent = iand(idyndat(idyn),15) + ivxtent = iand(idyndat(idyn),15) + * +16*igetbits(idynda2(idyn),1,10) + if (ivxtent .eq. ivx) then + iptent = igetbits(idyndat(idyn),8,4) + if (iptent .eq. ip) then + numdyn = numdyn+1 + idynn(numdyn) = idyn + else if (iptent .gt. ip) then +c +c I don't think there are any more possible for this ivx,ip, so exit loop +c + go to 2 + end if +c else if (ivxtent .gt. ivx) then +c go to 2 + end if +1 continue +2 continue +c +c At this point there is a list of idyn's in idynn(1...numdyn) +c Compute level, and stem-dir'n-based horizontal tweaks +c + hoffsd = 0. +c +c Set upstem to false as default +c + upstem = .false. + if (btest(irest,0)) then +c +c It's a rest. Assume it doesn't go below the staff +c + lbot = ncm-4 + else if (.not.beamon) then + if (udqq(nolev,ncm,islur,nvmx,ivx,nv).eq.'u' .or. nostem) then + upstem = .true. + if (.not.btest(ipl,10)) then + lbot = min(nolev-1,ncm-4) + else + lbot = min(minlev-1,ncm-4) + end if + else + hoffsd = -.5 + if (.not.btest(ipl,10)) then + lbot = min(nolev-7,ncm-4) + else + lbot = min(minlev-7,ncm-4) + end if + end if + else + if (ulq(ivx,ibmcnt) .eq. 'u') then + upstem = .true. + if (.not.btest(ipl,10)) then + lbot = min(nolev-1,ncm-4) + else + lbot = min(minlev-1,ncm-4) + end if + else + hoffsd = -.5 + lbot = ihornb(ivx,nornb(ivx))+1 + if (lbot .eq. 1) then +c +c Kluge for non-beamed, down xtup, for which ihorb was never set. +c Assumes stem is shortened. +c + lbot = nolev-5 + end if + nornb(ivx) = nornb(ivx)+1 + end if + end if + lbot = lbot-5 + jtxtdyn1 = 1 +c +c Now ready to loop over current dyn's +c + do 3 icntdyn = 1 , numdyn + idynd = idyndat(idynn(icntdyn)) + idynd2 = idynda2(idynn(icntdyn)) + idno = igetbits(idynd,4,12) +c ivx = iand(15,idynd) + ivx = iand(15,idynd)+16*igetbits(idynd2,1,10) +c +c Build the command into notex in stages. Insert name & rq'd args in order: +c +c Command name +c hpstrt, hpcend, hpdend, pmxdyn +c ivx +c X X X +c level +c X X X +c hoff +c X X X X +c d-mark +c X +c + if (idno .eq. 0) then +c +c Text-dynamic +c + notexq = chax(92)//'txtdyn' + lnote = 7 + else if (idno .le. 12) then +c +c Letter-group +c + notexq = chax(92)//'pmxdyn' + lnote = 7 + else if (fontslur) then + lnote = 7 + if (idno .eq. 13) then +c +c Start a hairpin +c + notexq = chax(92)//'hpstrt' + else if (idno .eq. 14) then +c +c End crescendo +c + notexq = chax(92)//'hpcend' + else +c +c End decrescendo +c + notexq = chax(92)//'hpdend' + end if + else +c +c Postscript hairpins +c + lnote = 7 + if (idno .eq. 13) then + notexq = chax(92)//'Icresc' + else if (idno .eq.14) then + notexq = chax(92)//'Idecresc' + lnote = 9 + else + notexq = chax(92)//'Tcresc' + end if + end if + if (idno .ge. 13) then +c +c Put in voice number +c + if (ivx .le. 9) then + notexq = notexq(1:lnote)//char(48+ivx) + lnote = lnote+1 + else if (ivx .le. 19) then + notexq = notexq(1:lnote)//'{1'//char(38+ivx)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//char(28+ivx)//'}' + lnote = lnote+4 + end if + end if +c +c Begin setting level +c + lbot1 = lbot + if (idno.gt.0 .and. idno.le.5) then +c +c All letters are short so raise a bit. +c + lbot1 = lbot1+1 + else if (idno .ge. 13) then + lbot1 = lbot1+2 + end if +c +c Convert so reference is bottom line +c + lbot1 = lbot1-ncm+4 + if ((fontslur.and.idno.eq.13) .or. + * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then +c +c Hairpin start. Save level and user-tweak before applying user tweak. +c + levdsav(ivx) = lbot1 + levhssav(ivx) = 0 + if (btest(idynd,16)) levhssav(ivx) = -64+igetbits(idynd,7,17) + else if ((fontslur.and.idno.ge.14) .or. idno.eq.15) then +c +c Hairpin end; Compare level with saved start level before user-tweaks +c + lbot1 = min(lbot1,levdsav(ivx)) +c +c Save pre-tweak level +c + lpretweak = lbot1 + end if +c +c Check for user-defined vertical tweak +c + if (btest(idynd,16)) lbot1 = lbot1-64+igetbits(idynd,7,17) +c +c Now horizontal stuff +c + hoff = hoffsd +c +c Some special horizontal tweaks +c + if (upstem .and. idno.gt.0 .and. + * (idno.le.4 .or. idno.eq.8 .or. idno.eq.9)) hoff = hoff+.4 +c +c User-defined tweaks +c + if (btest(idynd2,0)) + * hoff = hoff+(igetbits(idynd2,9,1)-256)*.1 + if (numdyn .gt. 1) then +c +c Horizontal-interaction-based tweaks. +c +c Cases: +c numdyn type1 type2 type3 data used +c 2 wrd-grp hrpnstrt - ivowg(1...12),hoh1(1...12) +c 2 hrpnend wrd-grp - ivowg,hoh2 +c 2 hrpnend hrpnstrt - hoh2h1(1...2) +c 3 hrpnend wrd-grp hrpnstrt ivowg,hoh2,hoh1 +c + if (idno.gt.0 .and. idno.le.12) then +c +c Word-group, may need vertical tweak to line up. +c + lbot1 = lbot1+ivowg(idno) +c +c Protecting against hp start-stop on same note +c + else if (((fontslur.and.idno.ge.14).or.idno.eq.15) + * .and. icntdyn.lt.numdyn) then +c +c Hairpin ending, check next type +c + if ((fontslur .and. + * igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13) + * .or. (.not.fontslur .and. + * ((igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.13) + * .or. + * (igetbits(idyndat(idynn(icntdyn+1)),4,12).eq.14)))) + * then +c +c Hairpin end then hairpin start, no words, (remember dealing with end now) +c + hoff = hoff+hoh2h1(1) + else +c +c Hairpin end then word-group, need idno for w-g to set hp offset +c + hoff = hoff + + * hoh2(igetbits(idyndat(idynn(icntdyn+1)),4,12)) + end if +c +c Protecting against hp start-stop on same note +c + else if (icntdyn.gt.1 .and. idno.gt.0 .and. + * ((fontslur.and.idno.lt.14).or. + * (.not.fontslur.and.idno.lt.15))) then +c +c Hairpin start, check prior type +c + if ((fontslur.and. + * igetbits(idyndat(idynn(icntdyn-1)),4,12).ge.14) + * .or. + * (.not.fontslur.and. + * igetbits(idyndat(idynn(icntdyn-1)),4,12).eq.15)) + * then +c +c Hairpin end then hairpin start, (remember dealing with start now) +c + hoff = hoff+hoh2h1(2) + else +c +c Hairpin start after word-group, need idno for w-g to set hp offset +c + hoff = hoff+ + * hoh1(igetbits(idyndat(idynn(icntdyn-1)),4,12)) + end if + end if + end if +c +c End of if-block for 2- or 3-way interactions. +c + if ((.not.fontslur) .and. idno.ge.13) +c +c Slur font and hairpin. Add hoff, and change from \interneote to \qn@width +c + * hoff = (hoff+.5)*6./2.5 +c +c Position corrections all done now. Put in the level. +c + if ((fontslur.and.idno.eq.13) .or. + * ((.not.fontslur).and.(idno.eq.13.or.idno.eq.14))) then +c +c Hairpin start. +c + if (.not.fontslur) then +c +c Postscript hairpin start...inset placeholder for start level. + + notexq = notexq(1:lnote)//'{ }' + lnote = lnote+5 + end if + else +c +c Insert actual level in all cases except hairpin start +c Create string with level in it +c + if (lbot1 .gt. 9) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else if (lbot1 .gt. -1) then + numpq = char(48+lbot1) + lnumpq = 1 + else if (lbot1 .gt. -10) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else + numpq = '{' + write(numpq(2:4),'(i3)')lbot1 + numpq = numpq(1:4)//'}' + lnumpq = 5 + end if +c +c Level has now been computed and stored in numpq +c Append the level +c + notexq = notexq(1:lnote)//numpq(1:lnumpq) + lnote = lnote+lnumpq + end if + if (abs(hoff) .lt. .001) then +c +c No horiz offset +c + notexq = notexq(1:lnote)//'0' + lnote = lnote+1 + else +c +c Horizontal tweak +c + lform = lfmt1(hoff) + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + write(notexq(lnote+1:lnote+lform), + * '(f'//chax(48+lform)//'.1)')hoff + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + if (idno .eq. 0) then +c +c text-dynamic. Find the string and append it +c + do 4 jtxtdyn = jtxtdyn1 , ntxtdyn +c ivxip = ivx+16*ip + ivxip = ivx+32*ip + if (ivxip .eq. ivxiptxt(jtxtdyn)) go to 5 +4 continue + call printl('Abnormal stop in putdyn') + call stop1() +5 continue + ltxtdyn = lenstr(txtdynq(jtxtdyn),128) +c +c Font size based on musicsize +c + if (musize .eq. 20) then + notexq = notexq(1:lnote)//'{'//char(92)//'medtype' + * //char(92)//'it ' + lnote = lnote+13 + else if (musize .eq. 16) then + notexq = notexq(1:lnote)//'{'//char(92)//'normtype' + * //char(92)//'it ' + lnote = lnote+14 + else if (musize .eq. 24) then + notexq = notexq(1:lnote)//'{'//char(92)//'bigtype' + * //char(92)//'it ' + lnote = lnote+13 + else if (musize .eq. 29) then + notexq = notexq(1:lnote)//'{'//char(92)//'Bigtype' + * //char(92)//'it ' + lnote = lnote+13 + end if + notexq = notexq(1:lnote)//txtdynq(jtxtdyn)(1:ltxtdyn) + * //'}' + lnote = lnote+ltxtdyn+1 +c +c Reset jtxtdyn1 just in case >1 txtdyn on same note. +c + jtxtdyn1 = jtxtdyn+1 + else if (idno .le. 12) then +c +c Letter-group dynamic. Append the letter-group command +c + id = 4*idno + dynstrq = dyntablq(id-3:id) + id = lenstr(dynstrq,4) + notexq = notexq(1:lnote)//chax(92)//dynstrq(1:id) + lnote = lnote+1+id + end if + call addstr(notexq(1:lnote),lnote,soutq,lsout) + if ((.not.fontslur).and.idno.eq.15) then +c +c PS slurs on, hairpin is ending. Go back and set height at beginning. +c Add user-defined tweak to default level +c + lbot1 = lpretweak+levhssav(ivx) + if (lbot1 .gt. 9) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else if (lbot1 .gt. -1) then + numpq = char(48+lbot1) + lnumpq = 1 + else if (lbot1 .gt. -10) then + numpq = '{' + write(numpq(2:3),'(i2)')lbot1 + numpq = numpq(1:3)//'}' + lnumpq = 4 + else + numpq = '{' + write(numpq(2:4),'(i3)')lbot1 + numpq = numpq(1:4)//'}' + lnumpq = 5 + end if +c +c Construct string to search backwards for placeholder +c + if (ivx .le. 9) then + tempq = 'cresc'//char(48+ivx)//'{ }' + ltemp = 11 + else if (ivx .le. 19) then + tempq = 'cresc'//'{1'//char(38+ivx)//'}{ }' + ltemp = 14 + else + tempq = 'cresc'//'{2'//char(28+ivx)//'}{ }' + ltemp = 14 + end if + write(11,'(a)')soutq(1:lsout)//'%' + lsout = 0 + call backfill(11,tempq,ltemp, + * tempq(1:ltemp-5)//numpq(1:lnumpq),ltemp-5+lnumpq) + end if +3 continue +c +c Shrink arrays, decrease ndyn 111109 +c + do 6 icntdyn = numdyn, 1 , -1 + do 7 jdyn = idynn(icntdyn) , ndyn-1 + idyndat(jdyn) = idyndat(jdyn+1) + idynda2(jdyn) = idynda2(jdyn+1) +7 continue + ndyn = ndyn-1 +6 continue + end + subroutine dograce(ivx,ip,ptgr,soutq,lsout,ncm,nacc,ig,ipl, + * farend, + * beamon,nolev,ncmidx,islur,nvmx,nv,ibmcnt,tnote,ulq) +c +c ip will be one LESS than current note, for way-after's before bar-end, +c It is only used to find ig. +c ig is returned to makeabar in case there's a slur that needs to be ended +c + parameter (nm=24) + logical beamon,stemup + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comoct/ noctup + logical upg,slurg,slashg,bar1syst,upslur,btest,isgaft,iswaft, + * normsp,farend,fontslur,WrotePsslurDefaults + real*4 ptgr(37) + character*80 soutq + character*128 litq + character*79 notexq + character*20 voltxtq + character*10 figq + character*8 noteq,noteqGA + character*3 acsymq + character*1 sq,chax,udqq,ulq(nm,9) + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + sq = chax(92) + isgaft = btest(ipl,29) + iswaft = btest(ipl,31) + normsp = .not. isgaft +c +c Find ig. +c + do 120 ig = 1 , ngrace + if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 121 +120 continue + print*,'Problem finding grace index in dograce' + stop +121 continue + ngs = ngstrt(ig) + mg = multg(ig) + wheadpt1 = wheadpt*fullsize(ivx) +c +c For way-after-graces at end of bar, must set the octave. +c + if (farend) then + noctup = 0 + if (ncm .eq.23) noctup = -2 + end if + if (slurg(ig) .and. .not.iswaft .and..not.isgaft) then + if (listslur .eq. 16777215) then + print* + print*,'You defined the twentyfifth slur, one too many!' + write(15,'(/,a)') + * 'You defined the twentyfifth slur, one too many!' + call stop1() + end if +c +c Slur on fore-grace. Get index of next slur not in use, from 23 down. +c + ndxslur = log2(16777215-listslur) + + end if + if (nng(ig) .eq. 1) then +c +c Single grace. +c + if (normsp) then +c +c Anything but GA +c + call addstr(sq//'shlft',6,soutq,lsout) + niptgr = nint(ptgr(ig)) +c +c Empirical tweak for postscript. +c +C if (.not.fontslur) niptgr = niptgr+nint(wheadpt*.3) +c++ + if (niptgr .lt. 10) then + call addstr(chax(48+niptgr)//'{',2,soutq,lsout) + else if (niptgr .lt. 100) then + write(notexq(1:2),'(i2)')niptgr + call addstr('{'//notexq(1:2)//'}{',5,soutq,lsout) + else + print*, + * 'Call Dr. Don if you really want grace note group > 99 pt' + stop + end if + else + call addstr(sq//'gaft{1.5}{',11,soutq,lsout) +c +c GA. Compute aftshft, for later use. +c + aftshft = grafac + if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+agc1fac + aftshft = aftshft*wheadpt + end if + if (slurg(ig) .and. .not.isgaft .and..not.iswaft) then +c +c Start slur on pre-grace. No accounting needed since will be ended very soon. +c + call notefq(noteq,lnoten,nolevg(ngs),ncm) + if (fontslur) then + if (upg(ig)) then + call addstr(sq//'islurd',7,soutq,lsout) + else + call addstr(sq//'isluru',7,soutq,lsout) + end if + else +c +c Start Postscript slur. +c + if (upg(ig)) then + call addstr(sq//'isd',4,soutq,lsout) + else + call addstr(sq//'isu',4,soutq,lsout) + end if + end if +c +c Print slur number, 23-ndxslur +c + lnote = 0 + if (23-ndxslur .lt. 10) then +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = chax(71-ndxslur) + lnote = 1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = '{1'//chax(61-ndxslur)//'}' + lnote = 4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = 4 + end if +c if (11-ndxslur .lt. 10) then +c call addstr(chax(59-ndxslur)//noteq(1:lnoten),1+lnoten, +c * soutq,lsout) +c else +c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), +c * 4+lnoten,soutq,lsout) +c end if + call addstr(notexq(1:lnote)//noteq(1:lnoten), + * lnote+lnoten,soutq,lsout) + if (.not.fontslur) then +c +c Horizontal tweaks for postscript slur on single grace +c + stemup = .true. + if (upg(ig)) then +c +c Check for up-grace + down stem. Get stem direction +c + if (.not.beamon) then +c +c Separate note. Get stem direction. +c + stemup = udqq(nolev,ncmidx, + * islur,nvmx,ivx,nv) .eq. 'u' + else +c +c In a beam +c + stemup = ulq(ivx,ibmcnt) .eq. 'u' + end if +c +c Stop the shift if whole note +c + stemup = stemup .or. tnote.gt.63 + end if + if (stemup) then + call addstr('{-.3}',5,soutq,lsout) + else + call addstr('{-.8}',5,soutq,lsout) + end if + end if + end if + if (naccg(ngs) .gt. 0) then + call notefq(noteq,lnoten,nolevg(ngs),ncm) +c +c Save for checking octave shifts in GA +c + if (isgaft) then + lnotenGA = lnoten + noteqGA = noteq + end if +c + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call accsym(naccg(ngs),acsymq,lacc) + call addstr(sq//'big'//acsymq(1:lacc)// + * noteq(1:lnoten),4+lacc+lnoten,soutq,lsout) + end if + if (slashg(ig)) then + notexq = sq//'grc' + lnote = 4 + else if (mg .eq. 0) then + notexq = sq//'zq' + lnote = 3 + else + notexq = sq//'zc' + do 61 i = 2 , mg + notexq = notexq(1:i+1)//'c' +61 continue + lnote = mg+2 + end if + if (upg(ig)) then + notexq = notexq(1:lnote)//'u' + else + notexq = notexq(1:lnote)//'l' + end if + call addstr(notexq,lnote+1,soutq,lsout) + call notefq(noteq,lnoten,nolevg(ngs),ncm) +c + if (isgaft .and. naccg(ngs).eq.0) then + lnotenGA = lnoten + noteqGA = noteq + end if +c + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call addstr(noteq,lnoten,soutq,lsout) + if (slashg(ig)) call addstr(sq//'off{-'//sq// + * 'noteskip}',16,soutq,lsout) +c +c Above code needed since slashg causes spacing +c + if (slurg(ig) .and. (iswaft.or.isgaft)) then +c +c Terminate slur on single after-grace +c +c ndxslur = igetbits(ipl,4,23) + ndxslur = igetbits(ipl,5,23) + call notefq(noteq,lnoten,nolevg(ngs),ncm) + call addstr(sq//'tslur',6,soutq,lsout) +c +cc Print 11-ndxslur +c Print 24-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c call addstr(chax(59-ndxslur)//noteq(1:lnoten), + call addstr(chax(71-ndxslur)//noteq(1:lnoten), + * 1+lnoten,soutq,lsout) + else if (23-ndxslur .lt. 20) then + call addstr('{2'//chax(61-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + else +c call addstr('{1'//chax(49-ndxslur)//'}'//noteq(1:lnoten), + call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + end if + slurg(ig) = .false. + listslur = ibclr(listslur,ndxslur) + end if + call addstr('}',1,soutq,lsout) +c +c+++ Try to fix loss of octave with single gaft +c +c if (isgaft) call addstr(sq//'zcharnote'//noteq(1:lnoten)//'{~}', +c * 13+lnoten,soutq,lsout) + if (isgaft) then + itrans = 0 + do 1 i = 1 , lnotenGA + if (noteqGA(i:i) .eq. chax(39)) then + itrans = itrans+7 + else if (noteqGA(i:i) .eq. chax(96)) then + itrans = itrans-7 + end if +1 continue + if (itrans. eq. -14) then + call addstr(sq//'advance'//sq//'transpose-14',21, + * soutq,lsout) + else if (itrans .eq. -7) then + call addstr(sq//'advance'//sq//'transpose-7',20, + * soutq,lsout) + else if (itrans .eq. 7) then + call addstr(sq//'advance'//sq//'transpose7',19, + * soutq,lsout) + else if (itrans .eq. 14) then + call addstr(sq//'advance'//sq//'transpose14',20, + * soutq,lsout) + end if + end if + else +c +c Multiple grace. Put in literally. Compute beam stuff +c + sumx = 0. + sumy = 0. + sumxy = 0. + sumxx = 0. + sumyy = 0. + x = 0. + do 118 ing = ngs , ngs+nng(ig)-1 + if (ing.gt.ngs .and. naccg(ing).gt.0) x = x+acgfac + y = nolevg(ing) + sumx = sumx + x + sumy = sumy + y + sumxy = sumxy + x*y + sumxx = sumxx + x*x + sumyy = sumyy + y*y + x = x+emgfac +118 continue + delta = nng(ig)*sumxx-sumx*sumx + em = (nng(ig)*sumxy-sumx*sumy)/delta + islope = nint(0.5*em*gslfac) + if (iabs(islope) .gt. 9) islope = isign(9,islope) + beta = (sumy-islope/gslfac*sumx)/nng(ig) + nolev1 = nint(beta) +c +c Back up +c + notexq = sq//'settiny'//sq//'off{' + if (normsp) then + write(notexq(14:18),'(a1,f4.1)')'-',ptgr(ig) + call addstr(notexq(1:18)//'pt}',21,soutq,lsout) + finalshift = ptgr(ig) + else + aftshft = wheadpt*1.33 + if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+wheadpt*0.5 + write(notexq(14:17),'(f4.1)')aftshft + call addstr(notexq(1:17)//'pt}'//sq//'bsk',24,soutq,lsout) + end if +c +c Start the beam +c + notexq = sq//'ib' + do 119 ing = 2 , mg + notexq = notexq(1:ing+1)//'b' +119 continue + if (upg(ig)) then + notexq = notexq(1:mg+2)//'u' + else + notexq = notexq(1:mg+2)//'l' + end if + notexq = notexq(1:mg+3)//'0' +c +c Get starting note for beam +c + call notefq(noteq,lnoten,nolev1,ncm) + call addstr(notexq(1:mg+4)//noteq(1:lnoten), + * mg+4+lnoten,soutq,lsout) +c +c Put in the slope +c + if (islope .ge. 0) then + call addstr(chax(48+islope),1,soutq,lsout) + else + call addstr('{-'//chax(48-islope)//'}',4,soutq,lsout) + end if +c +c Start a slur on multiple fore-grace +c + if (slurg(ig) .and. .not.isgaft .and. .not.iswaft) then + call notefq(noteq,lnoten,nolevg(ngs),ncm) + if (fontslur) then + if (upg(ig)) then + call addstr(sq//'islurd',7,soutq,lsout) + else + call addstr(sq//'isluru',7,soutq,lsout) + end if + else +c +c Need a tweak for postscript slur +c + if (upg(ig)) then + call addstr(sq//'isd',4,soutq,lsout) + else + call addstr(sq//'isu',4,soutq,lsout) + end if + end if +c +c Print 11-ndxslur +c + if (23-ndxslur .lt. 10) then + call addstr(chax(71-ndxslur)//noteq(1:lnoten),1+lnoten, + * soutq,lsout) + else if (23-ndxslur .lt. 2) then + call addstr('{1'//chax(61-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + else + call addstr('{1'//chax(51-ndxslur)//'}'//noteq(1:lnoten), + * 4+lnoten,soutq,lsout) + end if +c +c Put in tweak for postscript slur +c + if (.not.fontslur) call addstr('{-.3}',5,soutq,lsout) + end if +c +c Put in first note. Call notefq again in case octave changed +c + call notefq(noteq,lnoten,nolevg(ngs),ncm) + if (naccg(ngs) .eq. 0) then + notexq = sq//'zqb0'//noteq(1:lnoten) + lnote = 5+lnoten + else + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call accsym(naccg(ngs),acsymq,lacc) + notexq = sq//'big'//acsymq(1:lacc)//noteq(1:lnoten) + lnote = 4+lacc+lnoten + call notefq(noteq,lnoten,nolevg(ngs),ncm) + notexq =notexq(1:lnote)//sq//'zqb0'//noteq(1:lnoten) + lnote = lnote+5+lnoten + end if + call addstr(notexq,lnote,soutq,lsout) + do 127 ing = ngs+1 , ngs+nng(ig)-1 +c +c Skip +c + ptoff = wheadpt1*emgfac + if (naccg(ing).gt.0) ptoff = ptoff+wheadpt1*acgfac + if (isgaft .and. .not.iswaft) aftshft = aftshft+ptoff + notexq = sq//'off{' + write(notexq(6:8),'(f3.1)')ptoff + if (normsp) finalshift = finalshift-ptoff + call addstr(notexq(1:8)//'pt}',11,soutq,lsout) + if (ing .eq. ngs+nng(ig)-1) then +c +c Terminate beam if needed +c + if (upg(ig)) then + call addstr(sq//'tbu0',5,soutq,lsout) + else + call addstr(sq//'tbl0',5,soutq,lsout) + end if +c +c Terminate after slur if needed +c + if ((isgaft.or.iswaft) .and. slurg(ig)) then +c if (iswaft) ndxslur = igetbits(ipl,4,23) + if (iswaft) ndxslur = igetbits(ipl,5,23) + call notefq(noteq,lnoten,nolevg(ing),ncm) + call addstr(sq//'tslur',6,soutq,lsout) +c +c Print 11-ndxslur +cc Print 23-ndxslur +c + if (23-ndxslur .lt. 10) then + call addstr(chax(71-ndxslur)//noteq(1:lnoten), + * 1+lnoten,soutq,lsout) + else if (23-ndxslur .lt. 20) then + call addstr('{2'//chax(61-ndxslur)//'}' + * //noteq(1:lnoten),4+lnoten,soutq,lsout) + else + call addstr('{1'//chax(51-ndxslur)//'}' + * //noteq(1:lnoten),4+lnoten,soutq,lsout) + end if +c +c Stop slur terminator after exit from this subroutine +c + listslur = ibclr(listslur,ndxslur) + slurg(ig) = .false. + end if + end if +c +c Accidental if needed +c + if (naccg(ing).gt.0) then + call notefq(noteq,lnoten,nolevg(ing),ncm) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + call accsym(naccg(ing),acsymq,lacc) + call addstr(sq//'big'//acsymq(1:lacc) + * //noteq(1:lnoten),4+lacc+lnoten,soutq,lsout) + end if +c +c Put in the (beamed) grace note +c + call notefq(noteq,lnoten,nolevg(ing),ncm) + call addstr(sq//'zqb0'//noteq(1:lnoten),5+lnoten, + * soutq,lsout) +127 continue +c +c Terminate the grace +c +c notexq = sq//'normalnotesize'//sq//'off{' +c lnote = 20 +c notexq = '}'//sq//'off{' +c lnote = 6 + notexq = sq//'off{' + lnote = 5 + ptoff = wheadpt*emgfac + if (iand(nacc,3).gt.0 .and. .not.btest(nacc,17)) + * ptoff = ptoff+wheadpt*accfac + if (isgaft .and. .not.iswaft) then + notexq = notexq(1:5)//'-' + lnote = 6 + ptoff = aftshft + end if + if (normsp) ptoff = finalshift + if (ptoff .lt. 9.95) then + write(notexq(lnote+1:lnote+3),'(f3.1)')ptoff + lnote = lnote+3 + else if (ptoff .lt. 99.95) then + write(notexq(lnote+1:lnote+4),'(f4.1)')ptoff + lnote = lnote+4 + else + write(notexq(lnote+1:lnote+5),'(f5.1)')ptoff + lnote = lnote+5 + end if + call addstr(notexq(1:lnote)//'pt}',lnote+3,soutq,lsout) + if (isgaft.and..not.iswaft) call addstr(sq//'sk',3,soutq,lsout) + call addstr(sq//'resetsize',10,soutq,lsout) + end if + return + end + subroutine dopsslur(nolev,isdat1,isdat2,isdat3,isdat4,nsdat,ip, + * iv,kv,nv,beamon,ncm,soutq,lsout,ulq,islur, + * ipl,iornq,islhgt,tno,nacc) +c +c Called once per main note. +c 12 May 2002 Create this subroutine to isolate postscript slurs/ties. +c Always set \Nosluradjust\Notieadjust +c + parameter (nm=24,mv=24576) + integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comsln/ is1n1,is2n1,irzbnd,isnx + character*1 ulq,slurudq,udfq,udqq,chax + character*79 notexq + character*8 noteq + character*80 soutq + logical upslur,beamon,btest,stemup,iscrd, + * settie,fontslur,pstie,WrotePsslurDefaults + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi +c +c Bits in isdat1: +c 13-17 iv +c 3-10 ip +c 11 start/stop switch +c 12 kv-1 +c 19-25 ichar(code$) +c 26 force direction? +c 27 forced dir'n = up if on, set in sslur; also +c final direction, set in doslur when beam is started, used on term. +c 28-31 mod(ndxslur,16), set in doslur when slur is started, used on term. +c 18 int(ndxslur/16), ditto. So this allows ndxslur>15. +c +c Bits in isdat2 +c 0 Chord switch. Not set on main note. +c 1-2 left/right notehead shift. Set only for chord note. +c 3 tie positioning +c 4 dotted flag +c 6-11 voff1 1-63 => -31...+31 +c 12-18 hoff1 1-127 => -6.3...+6.3 +c 19-25 nolev +c 26 \sluradjust (p+s) +c 27 \nosluradjust (p-s) +c 28 \tieadjust (p+t) +c 29 \notieadjust (p-t) +c +c Bits in isdat3: Only used for slur endings +c 0 set if midslur (at least one argument) +c 1 set if curve (2 more args) +c 2-7 32+first arg (height correction) (1st arg may be negative) +c 8-10 second arg (initial slope) +c 11-13 third arg (closing slope) +c 14-21 tie level for use in LineBreakTies +c 22-29 ncm for use in LineBreakTies +c +c Bits in isdat4 Only used for linebreak slurs +c 0-5 Linebreak seg 1 voff 1-63 => -31...+31 +c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 +c 16-21 Linebreak seg 2 voff 1-63 => -31...+31 +c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 +c +c In listslur bit ib is on if slur index ib is in use, ib=0-13. +c ndxslur = slur index +c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, +c s-slur is blank (idcode=32), t-slur is idcode=1. +c ivoff is user-defined shift or shift due to . or _ , or chord adjustment. +c Ivoff will be set for ./_ only if no user-defined shift is specified. +c If highest note has upslur, save slur height in islhgt in case +c ornament must be moved. +c + islhgt = 0 + if (beamon) then + stemup = ulq .eq. 'u' + else if (nvmx(iv) .eq. 2) then + if (.not.btest(islur,30)) then +c +c Single note, 2 lines of music, stem direction not forced +c + stemup = ivx .gt. nv + else + stemup = btest(islur,17) + end if + else + stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u' + end if + iscrd = btest(ipl,10) + if (ismidi) then + settie = .false. + dbltie = .false. + end if + do 1 isdat = 1 , nsdat + isdata = isdat1(isdat) + if (iv .eq. igetbits(isdata,5,13) .and. + * ip .eq. igetbits(isdata,8,3) .and. + * kv .eq. igetbits(isdata,1,12)+1) then +c +c Since iv and kv match, ivx will be correct +c + idcode = igetbits(isdata,7,19) + ivoff = igetbits(isdat2(isdat),6,6)-32 + ihoff = igetbits(isdat2(isdat),7,12)-64 + iupdn = 0 + slurudq = 'd' + nolevs = igetbits(isdat2(isdat),7,19) + pstie = btest(isdat2(isdat),3) .or. idcode.eq.1 + if (btest(isdata,11)) then +c +c Turnon +c +c if (nolevs.eq.0 .or. nolevs.gt.60) then +cc +cc Note was a rest, cannot start slur on rest. +cc +c print* +c call printl('Cannot start slur on a rest') +c call stop1() +c nolevs = ncm+5 +c end if +c +c Get slur direction +c + if (btest(isdata,26)) then +c +c Force slur direction +c + if (btest(isdata,27)) slurudq = 'u' + else if (nvmx(iv) .eq. 1) then +c +c Only one voice per line +c + if (.not.beamon) then +c +c Separate note. +c + slurudq = udfq(nolev,ncm) + else +c +c In a beam +c + if (ulq .ne. 'u') slurudq = 'u' + end if + if (iscrd) then + if (nolevs .gt. ncm) then + slurudq = 'u' + else + slurudq = 'd' + end if + end if + else +c +c Two voices per line. Get default +c + if (ivx .gt. nv) slurudq = 'u' +c +c Upper voice of the two, so up slur +c + end if +c +c Set level for slur starting on rest +c + if (nolevs.eq.0 .or. nolevs.gt.60) then + if (slurudq .eq. 'u') then + nolevs = ncm+2 + else + nolevs = ncm-2 + end if + end if +c +c Save up/down-ness for use at termination +c + if (slurudq .eq. 'u') isdata = ibset(isdata,27) +c +c End of section for setting slur direction, still in "Turnon" if-block. +c + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then +c +c Must move the slur for _ or . +c + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + ivoff = ivoff+ivoffinc + end if + end if + if (listslur .eq. 16777215) then + print* + print*,'You1 defined the twentyfifth slur, one too many!' + write(15,'(/,a)') + * 'You defined the twentyfifth slur, one too many!' + call stop1() + end if +c +c Get index of next slur not in use, starting from 12 down +c + ndxslur = log2(16777215-listslur) +c write(*,'()') +c write(*,'(2i4,2x,B24)')ivx,ndxslur,listslur +c +c Record slur index +c + listslur = ibset(listslur,ndxslur) +c write(*,'(10x,B24)')listslur +c +c Save for use on termination +c +c call setbits(isdata,4,28,ndxslur) +c 080531 Allow >16 slurs + call setbits(isdata,4,28,mod(ndxslur,16)) + call setbits(isdata,1,18,ndxslur/16) +c +c Shift for stem? +c + if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) then + if (.not.pstie) then + ihoff = ihoff+8 + else + ihoff = ihoff+2 + end if + end if + if (iscrd) then +c +c Additional horiz shifts for h-shifted noteheads? +c + if (btest(isdat2(isdat),1)) then +c +c Slur start on left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + notexq = chax(92) + lnote = 1 +c +c Check for local adjustment default changes +c + if (btest(isdat2(isdat),26)) then + notexq = chax(92)//'sluradjust'//chax(92) + lnote = 12 + else if (btest(isdat2(isdat),27)) then + notexq = chax(92)//'nosluradjust'//chax(92) + lnote = 14 + else if (btest(isdat2(isdat),28)) then + notexq = chax(92)//'tieadjust'//chax(92) + lnote = 11 + else if (btest(isdat2(isdat),29)) then + notexq = chax(92)//'notieadjust'//chax(92) + lnote = 13 + end if + if (ihoff .eq. 0) then +c +c Write stuff for non-shifted start +c + notexq = notexq(1:lnote)//'islur'//slurudq + lnote = lnote+6 + else + notexq = notexq(1:lnote)//'is'//slurudq + lnote = lnote+3 + end if +c +c Prepend postscript tie switch +c + if (pstie) then + notexq = chax(92)//'tieforis'//slurudq//notexq(1:lnote) + lnote = lnote+10 + end if + if (btest(isdat2(isdat),4)) then +c +c Dotted slur +c +c noteq = notexq +c notexq = chax(92)//'dotted'//noteq + notexq = chax(92)//'dotted'//notexq(1:lnote) + lnote = lnote+7 + end if +c +c Add slur index to string +cc Print 11-ndxslur +c Print 23-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c +c 5/25/08 Allow 24 slurs +c +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if +c +c Add note name to string +c +c call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + islhgt = nolevs+iupdn+ivoff + call notefq(noteq,lnoten,islhgt,ncm) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten +c +c Store height and staff mid level for use with LineBreakTies +c + call setbits(isdat3(isdat),8,14,islhgt) + call setbits(isdat3(isdat),8,22,ncm) +c +c Save height (for ornament and barnobox interference) if topmost slur is up +c + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c Save height & idcode if top voice and slur start +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then + is1n1 = islhgt + is2n1 = idcode + end if + end if + if (ihoff .ne. 0.) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform),'(f'// + * chax(48+lform)//'.1)') shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Zero out ip1 to avoid problems if slur goes to next input blk. +c + call setbits(isdata,8,3,0) +c +c Set slur-on data for midi. Only treat null-index slurs and ps ties for now. +c + if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then +c levson(midchan(iv,kv)) = nolev + levson(midchan(iv,kv)) = nolevs + if (settie) dbltie = .true. +c +c Only way settie=T is if we just set a tie ending. So there's also a slur +c start here, so set a flag telling addmidi not to zero out levson +c + end if + else +c +c Slur is ending. Back thru list to find starting slur +c + do 3 j = isdat-1 , 1 , -1 + if (iv.eq.igetbits(isdat1(j),5,13) .and. + * kv.eq.igetbits(isdat1(j),1,12)+1) then + if (idcode .eq. igetbits(isdat1(j),7,19)) then + ndxslur = igetbits(isdat1(j),4,28) +c +c 080531 Allow >16 slurs +c + * +16*igetbits(isdat1(j),1,18) + if (btest(isdat1(j),27)) slurudq = 'u' + go to 4 + end if + end if +3 continue + print*,'Bad place in doslur' + call stop1() +4 continue +c +c Bugfix 070901 for slur ending on rest in 2-voice staff +c +c if (nolevs.eq.0 .or. nolevs.gt.60) then + if (nolevs.le.2 .or. nolevs.gt.60) then +c +c Ending is on a rest, reset nolevs to default starting height +c + nolevs = igetbits(isdat2(j),7,19) + end if + if (btest(isdat3(isdat),0) .or. btest(isdat3(j),0)) then +c +c Deal with \curve or \midslur. isdat is ending, j is start. +c + if (btest(isdat3(isdat),0)) then + imid = igetbits(isdat3(isdat),6,2)-32 + else + imid = igetbits(isdat3(j),6,2)-32 + end if +c +c Postscript slurs, and \midslur adjustment is needed. Invoke macro +c (from pmx.tex) that redefines \tslur as r'qd. Tentative mapping: +c Abs(imid) Postscript slur type +c 1 f +c 2-3 default +c 4 h +c 5 H +c 6+ HH +c + call addstr(chax(92)//'psforts'// + * chax(48+min(abs(imid),6)),9,soutq,lsout) + end if +c +c Shift slur ending for stem on any note? +c + if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.) then + if (.not.pstie) then + ihoff = ihoff-8 + else + ihoff = ihoff-3 + end if + end if + if (iscrd) then +c +c Shift termination for shifted notehead? +c + if (btest(isdat2(isdat),1)) then +c +c Left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + if (ihoff .eq. 0) then + notexq = chax(92)//'tslur' + lnote = 6 + else +c +c Shift needed +c + notexq = chax(92)//'ts' + lnote = 3 + end if +c +c Switch to postscript tie +c + if (pstie) then + notexq = chax(92)//'tieforts'//notexq(1:lnote) + lnote = lnote+9 + end if +c +c Print 13-ndxslur +c 5/25/08 Allow 14 slurs +c + if (23-ndxslur .lt. 10) then + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + end if + ivoff = ivoff+ivoffinc + end if + call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then + if (idcode .eq. is2n1) is1n1=0 + end if + end if + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (ihoff .ne. 0) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform), + * '(f'//chax(48+lform)//'.1)')shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Clear the bit from list of slurs in use +c + listslur = ibclr(listslur,ndxslur) +c +c Zero out the entire strings for start and stop +c + isdata = 0 + isdat2(isdat) = 0 + isdat3(isdat) = 0 + isdat4(isdat) = 0 + isdat1(j) = 0 + isdat2(j) = 0 + isdat3(j) = 0 + isdat4(j) = 0 +c +c Set midi info for slur ending +c + if (ismidi .and. (idcode.eq.32 .or. idcode.eq.1)) then + icm = midchan(iv,kv) + if (slmon(icm)) then + if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then +c +c There is a tie here. NB!!! assumed no accidental on 2nd member of tie. +c + levsoff(icm) = nolevs + settie = .true. + else + levsoff(icm) = 0 + levson(icm) = 0 + slmon(icm) = .false. + end if + end if + end if + end if + isdat1(isdat) = isdata + end if +1 continue +c +c Clear and collapse the slur data list +c + numdrop = 0 + do 2 isdat = 1 , nsdat + if (isdat1(isdat) .eq. 0) then + numdrop = numdrop+1 + else if (numdrop .gt. 0) then + isdat1(isdat-numdrop) = isdat1(isdat) + isdat2(isdat-numdrop) = isdat2(isdat) + isdat3(isdat-numdrop) = isdat3(isdat) + isdat4(isdat-numdrop) = isdat4(isdat) + isdat1(isdat) = 0 + isdat2(isdat) = 0 + isdat3(isdat) = 0 + isdat4(isdat) = 0 + end if +2 continue + nsdat = nsdat-numdrop +c call report(nsdat,isdat1,isdat2) + return + end + subroutine doslur(nolev,isdat1,isdat2,isdat3,nsdat,ip,iv,kv,nv, + * beamon,ncm,soutq,lsout,ulq,islur,ipl,iornq,islhgt,tno,nacc) +c +c Called once per main note. (5/26/02) for non-ps slurs only +c + parameter (nm=24,mv=24576) + integer*4 isdat1(202),isdat2(202),isdat3(202) + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comsln/ is1n1,is2n1,irzbnd,isnx + character*1 ulq,slurudq,udfq,udqq,chax + character*79 notexq + character*8 noteq + character*80 soutq + logical upslur,beamon,btest,stemup,iscrd,sfound,tfound,tmove, + * settie,fontslur,WrotePsslurDefaults + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi +c +c Bits in isdat1: +c 13-17 iv +c 3-10 ip +c 11 start/stop switch +c 12 kv-1 +c 19-25 ichar(code$) +c 26 force direction? +c 27 forced dir'n = up if on, set in sslur; also +c final direction, set in doslur when beam is started, used on term. +c 28-31 ndxslur, set in doslur when beam is started, used on term. +c +c Bits in isdat2 +c 0 Chord switch. Not set on main note. +c 1-2 left/right notehead shift. Set only for chord note. +c 3 tie positioning +c 4 dotted flag +c 6-11 voff1 1-63 => -31...+31 +c 12-18 hoff1 1-127 => -6.3...+6.3 +c 19-25 nolev +c +c Bits in isdat3: Only used for slur endings +c 0 set if midslur (at least one argument) +c 1 set if curve (2 more args) +c 2-7 32+first arg (height correction) (1st arg may be negative) +c 8-10 second arg (initial slope) +c 11-13 third arg (closing slope) +c +c In listslur bit ib is on if slur index ib is in use, ib=0-23. +c ndxslur = slur index +c Height of slur is nole+ivoff+iupdn. iupdn is +/-1 if t&s slurs on same note, +c s-slur is blank (idcode=32), t-slur is idcode=1. +c ivoff is user-defined shift or shift due to . or _ , or chord adjustment. +c Ivoff will be set for ./_ only if no user-defined shift is specified. +c If highest note has upslur, save slur height in islhgt in case +c ornament must be moved. +c + islhgt = 0 + if (beamon) then + stemup = ulq .eq. 'u' + else if (nvmx(iv) .eq. 2) then + if (.not.btest(islur,30)) then +c +c Single note, 2 lines of music, stem direction not forced +c + stemup = ivx .gt. nv + else + stemup = btest(islur,17) + end if + else + stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u' + end if + iscrd = btest(ipl,10) + if (btest(islur,1)) then +c +c 't'-slur (idcode=1) somewhere on this note. Find it, check height against +c 's'-slur (idcode=32) +c + sfound = .false. + tfound = .false. + tmove = .false. + do 5 isdat = 1 , nsdat + if (iv .eq. igetbits(isdat1(isdat),5,13) .and. + * ip .eq. igetbits(isdat1(isdat),8,3) .and. + * kv .eq. igetbits(isdat1(isdat),1,12)+1) then + if (.not.tfound) then + tfound = igetbits(isdat1(isdat),7,19).eq.1 + if (tfound) then + nolevt = igetbits(isdat2(isdat),7,19) + isdatt = isdat + if (sfound) go to 6 + end if + end if + if (.not.sfound) then + sfound = igetbits(isdat1(isdat),7,19).eq.32 + if (sfound) then + nolevs = igetbits(isdat2(isdat),7,19) + isdats = isdat + if (tfound) go to 6 + end if + end if + end if +5 continue +c +c Will come thru here if there is a t with no s, so comment out the following +c print*,'Did not find s+t-slurs in doslur' +c +6 continue + if (sfound .and. tfound) + * tmove = nolevs.eq.nolevt .and. +c +c Check if 2 starts or two stops +c + * ((btest(isdat1(isdats),11).and.btest(isdat1(isdatt),11)) .or. + * (.not.btest(isdat1(isdats),11).and. + * .not.btest(isdat1(isdatt),11)) ) +c +c This is a flag for later changing slur level, after we know slur dir'n. +c + end if + if (ismidi) then + settie = .false. + dbltie = .false. + end if + do 1 isdat = 1 , nsdat + isdata = isdat1(isdat) + if (iv .eq. igetbits(isdata,5,13) .and. + * ip .eq. igetbits(isdata,8,3) .and. + * kv .eq. igetbits(isdata,1,12)+1) then +c +c Since iv and kv match, ivx will be correct +c + idcode = igetbits(isdata,7,19) + ivoff = igetbits(isdat2(isdat),6,6)-32 + ihoff = igetbits(isdat2(isdat),7,12)-64 + iupdn = 0 + slurudq = 'd' + nolevs = igetbits(isdat2(isdat),7,19) + if (btest(isdata,11)) then +c +c Turnon, +c + if (nolevs.eq.0 .or. nolevs.gt.60) then +c +c Note was a rest, cannot start slur on rest. +c + print* + call printl('Cannot start slur on a rest') + call stop1() + end if +c +c Get slur direction +c + if (btest(isdata,26)) then +c +c Force slur direction +c + if (btest(isdata,27)) slurudq = 'u' + else if (nvmx(iv) .eq. 1) then +c +c Only one voice per line +c + if (.not.beamon) then +c +c Separate note. +c + slurudq = udfq(nolev,ncm) + else +c +c In a beam +c + if (ulq .ne. 'u') slurudq = 'u' + end if + if (iscrd) then + if (nolevs .gt. ncm) then + slurudq = 'u' + else + slurudq = 'd' + end if + end if + else +c +c Two voices per line. Get default +c + if (ivx .gt. nv) slurudq = 'u' +c +c Upper voice of the two, so up slur +c + end if +c +c Save up/down-ness for use at termination +c + if (slurudq .eq. 'u') isdata = ibset(isdata,27) +c +c End of section for setting slur direction, still in "Turnon" if-block. +c + if (idcode.eq.1 .and. tmove) then + iupdn = 1 + if (slurudq .eq. 'd') iupdn = -1 + end if + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then +c +c Must move the slur for _ or . +c + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + ivoff = ivoff+ivoffinc + end if + end if + if (listslur .eq. 16777215) then + print* + print*,'You1 defined the twenty-fifth slur, one too many!' + write(15,'(/,a)') + * 'You2 defined the twenty-fifth slur, one too many!' + call stop1() + end if +c +c Get index of next slur not in use, starting from ? down +c + ndxslur = log2(16777215-listslur) +c +c Record slur index +c + listslur = ibset(listslur,ndxslur) +c +c Save for use on termination +c +c call setbits(isdata,4,28,ndxslur) +c 080531 Allow >16 slurs + call setbits(isdata,4,28,mod(ndxslur,16)) + call setbits(isdata,1,18,ndxslur/16) +c +c Shift for stem? +c + if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) + * ihoff = ihoff+8 + if (btest(isdat2(isdat),3)) then +c +c Tie spacing, (slur start) +c + if (slurudq.eq.'d') then + ivoff = ivoff+1 + ihoff = ihoff+8 + else if (slurudq.eq.'u') then + ivoff = ivoff-1 + if (.not.(stemup.and.tno.lt.63.)) ihoff = ihoff+8 +c +c (already shifted if (stemup.and.tno.gt.63.) and slurudq='u') +c + end if + end if + if (iscrd) then +c +c Additional horiz shifts for h-shifted noteheads? +c + if (btest(isdat2(isdat),1)) then +c +c Slur start on left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + if (ihoff .eq. 0) then +c +c Write stuff for non-shifted start +c + notexq = chax(92)//'islur'//slurudq + lnote = 7 + else + notexq = chax(92)//'is'//slurudq + lnote = 4 + end if + if (btest(isdat2(isdat),4)) then +c +c Dotted slur +c + noteq = notexq + notexq = chax(92)//'dotted'//noteq + lnote = lnote+7 + end if +c +c Add slur index to string +cc Print 11-ndxslur +c Print 23-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c +c 5/25/08 Allow 24 slurs +c +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if +c +c Add note name to string +c + call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten +c +c Save height (for ornament and barnobox interference) if topmost slur is up +c + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c Save height & idcode if top voice and slur start +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then + is1n1 = islhgt + is2n1 = idcode + end if + end if + if (ihoff .ne. 0.) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform),'(f'// + * chax(48+lform)//'.1)') shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Zero out ip1 to avoid problems if slur goes to next input blk. +c + call setbits(isdata,8,3,0) +c +c Set slur-on data for midi. Only treat null-index slurs and ps ties for now. +c + if (ismidi .and. idcode.eq.32) then + levson(midchan(iv,kv)) = nolevs + if (settie) dbltie = .true. +c +c Only way settie=T is if we just set a tie ending. So there's also a slur +c start here, so set a flag telling addmidi not to zero out levson +c + end if + else +c +c Slur is ending. Back thru list to find starting slur +c + do 3 j = isdat-1 , 1 , -1 + if (iv.eq.igetbits(isdat1(j),5,13) .and. + * kv.eq.igetbits(isdat1(j),1,12)+1) then + if (idcode .eq. igetbits(isdat1(j),7,19)) then + ndxslur = igetbits(isdat1(j),4,28) +c +c 080531 Allow >16 slurs +c + * +16*igetbits(isdat1(j),1,18) + if (btest(isdat1(j),27)) slurudq = 'u' + go to 4 + end if + end if +3 continue + print*,'Bad place in doslur' + call stop1() +4 continue + if (nolevs.eq.0 .or. nolevs.gt.60) then +c +c Ending is on a rest, reset nolevs to default starting height +c + nolevs = igetbits(isdat2(j),7,19) + end if + if (btest(isdat3(isdat),0)) then +c +c Deal with \curve or \midslur +c + imid = igetbits(isdat3(isdat),6,2)-32 +c +c Remember, only dealing with non-ps slurs +c +c Who knows where the following line came from. Removed it 6/30/02 to +c restore behavior of non-ps slurs to old way +c if (slurudq .eq. 'd') imid = -imid +c 3/8/03 added the following +c + if (slurudq .eq. 'd') imid = -abs(imid) +c + if (btest(isdat3(isdat),1)) then + notexq = chax(92)//'curve' + lnote = 6 + else + notexq = chax(92)//'midslur' + lnote = 8 + end if + if (imid.lt.0 .or. imid.gt.9) then +c +c Need brackets +c + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (imid .lt. -9) then + write(notexq(lnote+1:lnote+3),'(i3)')imid + lnote = lnote+3 + else if (imid.lt.0 .or. imid.gt.9) then + write(notexq(lnote+1:lnote+2),'(i2)')imid + lnote = lnote+2 + else + write(notexq(lnote+1:lnote+1),'(i1)')imid + lnote = lnote+1 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + else +c +c 1=<imid=<9, no brackets +c + notexq = notexq(1:lnote)//char(48+imid) + lnote = lnote+1 + end if + if (btest(isdat3(isdat),1)) then +c +c \curve; 3 args +c + notexq = notexq(1:lnote) + * //char(48+igetbits(isdat3(isdat),3,8)) + notexq = notexq(1:lnote+1) + * //char(48+igetbits(isdat3(isdat),3,11)) + lnote = lnote+2 + end if + call addstr(notexq,lnote,soutq,lsout) + end if +c +c Shift slur ending for stem on any note? +c + if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.) + * ihoff = ihoff-8 + if (btest(isdat2(isdat),3)) then +c +c Shift ending for tie spacing +c + if (slurudq .eq. 'u') then + ihoff = ihoff-8 + ivoff = ivoff-1 + else if (slurudq .eq. 'd') then + ivoff = ivoff+1 + if (stemup.or. tno.gt.63.) ihoff = ihoff-8 + end if + end if + if (iscrd) then +c +c Shift termination for shifted notehead? +c + if (btest(isdat2(isdat),1)) then +c +c Left-shifted chord notehead. ASSUME downstem. +c + if (nolevs.eq.minlev .and. slurudq.eq.'d') then + ihoff = ihoff-2 + else + ihoff = ihoff-10 + end if + else if (btest(isdat2(isdat),2)) then +c +c Right shifted chord notehead. ASSUME upstem. +c + if (nolevs.eq.maxlev .and. slurudq.eq.'u') then + ihoff = ihoff+2 + else + ihoff = ihoff+10 + end if + end if + end if + if (ihoff .eq. 0) then + notexq = chax(92)//'tslur' + lnote = 6 + else +c +c Shift needed +c + notexq = chax(92)//'ts' + lnote = 3 + end if +c +c Print 23-ndxslur +c 5/25/08 Allow 14 slurs (???????????) +c + if (23-ndxslur .lt. 10) then + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if + if (btest(iornq,11).or.btest(iornq,12)) then +c +c Raise or lower slur by one unit provided . or _ is on same side as slur +c + ivoffinc = 0 + if ((stemup .and. slurudq.eq.'d') .or. + * (.not.stemup .and. slurudq.eq.'u')) then + if (stemup) then + ivoffinc = -1 + else + ivoffinc = 1 + end if + if (((stemup .and. nolev.ge.ncm-2) .or. + * (.not.stemup .and. nolev.le.ncm+2)) .and. + * mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc + end if + ivoff = ivoff+ivoffinc + end if + if (idcode.eq.1 .and. tmove) then +c +c t-slur height adjustment +c + iupdn = 1 + if (slurudq .eq. 'd') iupdn = -1 + end if + call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm) + if (slurudq.eq.'u' .and. + * (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then + islhgt = nolevs+iupdn+ivoff +c +c If topvoice, upslur, and idcode checks, no more need to keep hgt for barno. +c + if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then + if (idcode .eq. is2n1) is1n1=0 + end if + end if + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (ihoff .ne. 0) then + shift = ihoff*0.1 + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + lform = lfmt1(shift) + write(notexq(lnote+1:lnote+lform), + * '(f'//chax(48+lform)//'.1)')shift + lnote = lnote+lform + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq,lnote,soutq,lsout) +c +c Clear the bit from list of slurs in use +c + listslur = ibclr(listslur,ndxslur) +c +c Zero out the entire strings for start and stop +c + isdata = 0 + isdat2(isdat) = 0 + isdat1(j) = 0 + isdat2(j) = 0 + isdat3(isdat) = 0 +c +c Set midi info for slur ending +c + if (ismidi .and. idcode.eq.32) then + icm = midchan(iv,kv) + if (slmon(icm)) then + if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then +c +c There is a tie here. NB!!! assumed no accidental on 2nd member of tie. +c + levsoff(icm) = nolevs + settie = .true. + else + levsoff(icm) = 0 + levson(icm) = 0 + slmon(icm) = .false. + end if + end if + end if + end if + isdat1(isdat) = isdata + end if +1 continue +c +c Clear and collapse the slur data list +c + numdrop = 0 + do 2 isdat = 1 , nsdat + if (isdat1(isdat) .eq. 0) then + numdrop = numdrop+1 + else if (numdrop .gt. 0) then + isdat1(isdat-numdrop) = isdat1(isdat) + isdat2(isdat-numdrop) = isdat2(isdat) + isdat3(isdat-numdrop) = isdat3(isdat) + isdat1(isdat) = 0 + isdat2(isdat) = 0 + isdat3(isdat) = 0 + end if +2 continue + nsdat = nsdat-numdrop +c call report(nsdat,isdat1,isdat2) + return + end + subroutine dotmov(updot,rtdot,soutq,lsout,iddot) +c +c iddot = 0 for single dot, 1 for double +c + character*80 soutq,notexq + character*1 sq,chax + sq = chax(92) + lfmtup = lfmt1(updot) + lfmtrt = lfmt1(rtdot) + write(notexq,'(a37,f'//chax(48+lfmtup)//'.1,a2,f'//chax(48+lfmtrt) + * //'.1,a15)') + * sq//'makeatletter'//sq//'def'//sq//'C@Point#1#2{'//sq// + * 'PMXpt{',updot,'}{',rtdot,'}'//chax(48+iddot)//'}'//sq + * //'makeatother' +c +c Example of string just created: +c \makeatletter\def\C@Point#1#2{\PMXpt{.5}{.5}}\makeatother\ +c + lnote = 54+lfmtup+lfmtrt + call addstr(notexq(1:lnote),lnote,soutq,lsout) + return + end + subroutine dotrill(iv,ip,iornq,noteq,lnoten,notexq,lnote) + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + character*1 chax + character*8 noteq + character*79 notexq + logical tronly,btest + do 1 itr = 1 , ntrill + if (iv.eq.ivtrill(itr) .and. ip.eq.iptrill(itr)) go to 2 +1 continue + print*,'Problem in dotrill. Call Dr. Don' + stop +2 continue + tronly = xnsktr(itr) .lt. 0.01 + if (tronly) then + notexq = chax(92)//'zcharnote' + lnote = 10 + else if (btest(iornq,7)) then + notexq = chax(92)//'Trille' + lnote = 7 + else + notexq = chax(92)//'trille' + lnote = 7 + end if + notexq = notexq(1:lnote)//noteq(1:lnoten)//'{' + lnote = lnote+lnoten+1 +c +c Write trill duration to nearest tenth of a noteskip +c + if (tronly) then + notexq = notexq(1:lnote)//chax(92)//'it tr}' + lnote = lnote+7 + return + end if + if (xnsktr(itr) .lt. .95) then + nfmt = 2 + else if (xnsktr(itr) .lt. 9.95) then + nfmt = 3 + else + nfmt = 4 + end if + write(notexq(lnote+1:lnote+nfmt),'(f'//chax(48+nfmt)//'.1)') + * xnsktr(itr) + lnote = lnote+nfmt + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + return + end + subroutine endslur(stemup,upslur,nolev,iupdn,ndxslur,ivoff,ncm, + * soutq,lsout,fontslur) +c +c Only called to end slur started in dograce. +c + logical shift,stemup,upslur,fontslur + character*80 soutq + character*79 notexq + character*8 noteq + character*1 chax + shift = .not.stemup .and. .not.upslur + if (.not.shift) then +c +c No shift needed +c + notexq = chax(92)//'tslur' + lnote = 6 + else +c +c Shift needed +c + notexq = chax(92)//'ts' + lnote = 3 + end if +c if (ndxslur .lt. 10) then +c notexq = notexq(1:lnote)//chax(48+ndxslur) +c lnote = lnote+1 +c else +c notexq = notexq(1:lnote)//'{1'//chax(38+ndxslur)//'}' +c lnote = lnote+4 +c end if +c +cc Print 11-ndxslur +c Print 23-ndxslur +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c notexq = notexq(1:lnote)//chax(59-ndxslur) + notexq = notexq(1:lnote)//chax(71-ndxslur) + lnote = lnote+1 + else if (23-ndxslur .lt. 20) then +c notexq = notexq(1:lnote)//'{1'//chax(49-ndxslur)//'}' + notexq = notexq(1:lnote)//'{1'//chax(61-ndxslur)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndxslur)//'}' + lnote = lnote+4 + end if + call notefq(noteq,lnoten,nolev+iupdn+ivoff,ncm) + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + if (shift) then + if (fontslur) then + notexq = notexq(1:lnote)//'{-.6}' + else + notexq = notexq(1:lnote)//'{-.8}' + end if + lnote = lnote+5 + end if + call addstr(notexq,lnote,soutq,lsout) + return + end + subroutine errmsg(lineq,iccount,ibarno,msgq) + parameter(nm=24) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,fbon,issegno,isheadr,isvolt + character*128 lineq + character*78 outq + character*(*) msgq + character*1 chax + common /truelinecount/ linewcom(20000) + if (iccount .le. 78) then + outq = lineq(1:78) + iposn = iccount + else + outq = '... '//lineq(55:128) + iposn = iccount-50 + end if + print* + ibarnop = ibarno + if (linesinpmxmod.eq.0 .or. + * nline .gt. line1pmxmod+linesinpmxmod) then +c +c Error is in main .pmx file +c +c nlinep = nline-linesinpmxmod +c Correct for comments not copied into buffer + nlinep = linewcom(nline)-linesinpmxmod + else +c +c Error is in include file +c + ibarnop = 0 + nlinep = nline-line1pmxmod+1 + call printl( + * 'ERROR in include file named above, description given below') + end if + open(19,file='pmxaerr.dat') + write(19,'(i6)') nlinep + close(19) + ndigbn = max(1,int(log10(ibarnop+.1)+1)) + ndignl = int(log10(nlinep+.1)+1) + lenmsg = index(msgq,'!')-1 +c +c Split off msgq(..) since UNIX compilers don't allow concat substring!!! +c + write(*,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)// + *',$)')' ERROR in line ',nlinep,', bar ',ibarnop + write(*,'(1x,a)')msgq(1:lenmsg) + write(15,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)// + *',$)')' ERROR in line ',nlinep,', bar ',ibarnop + write(15,'(a)')msgq(1:lenmsg) + i10 = iposn/10 + i1 = iposn-10*i10 + write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v' + write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v' + print*,outq(1:78) + write(15,'(a)')' '//outq(1:78) + write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^' + write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^' + return + end + subroutine eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk) +c +c Get elemskips to previous note. Called only for graces, no xtups involved. +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + real*4 tstart(80),space(80) + common /comtol/ tol + itnd = nint(to(in)) + if (ip.eq.1 .or. itnd.eq.itrpt) then +c +c Start of bar or after rpt. +c + esk = fbar + return + else + esk = 0. + itprev = itnd-nodur(ivx,ip-1) + do 1 iib = ib , 1 , -1 + if (tstart(iib) .lt. itprev+tol) then +c +c This is the block +c + nnsk = nint(float((itnd-itprev))/space(iib)) + esk = esk+nnsk*feon(space(iib)) + return + else + nnsk = nint((itnd-tstart(iib))/space(iib)) + esk = esk+nnsk*feon(space(iib)) + itnd = nint(tstart(iib)) + end if +1 continue + end if + print*,'Problem in eskb4. Send files to Dr. Don' + stop + end + function f1eon(time) + f1eon = sqrt(time/2) + return + end + function feon(time) + common /comeon/ eonk,ewmxk + feon = sqrt(time/2)**(1.-eonk)*ewmxk + return + end + subroutine findbeam(ibmrep,numbms,mapfb) +c +c Called once per voice per bar, after setting forced beams. +c + parameter (nm=24) + dimension mask(49,3),nummask(3),eqonly(49,3) +c integer numbms(nm),ipr(48),nip1(0:47),nip2(0:47),mapfb(16), +c * itr(48),nodue(48) +c logical short(48),eqonly + integer numbms(nm),ipr(248),nip1(0:247),nip2(0:247),mapfb(16), + * itr(248),nodue(248) + logical short(248),eqonly + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + common /combeam/ ibmtyp + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtol/ tol + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk, + * isfig,btest + data nip1,nip2 /496*0/ + data nummask / 29 , 49 , 12 / + data mask + * / 65535, 4095, 65520, 255, 65280, 63, + * 252, 16128, 64512, 15, 240, 3840, + * 61440, 7, 14, 112, 224, 1792, + * 3584, 28672, 57344, 3, 12, 48, + * 192, 768, 3072, 12288, 49152, 20*0 , + * 16777215, 65535, 16776960, 4095, 65520, 1048320, + * 16773120, 255, 65280, 16711680, 63, 252, + * 16128, 64512, 4128768, 16515072, 15, 60, + * 240, 3840, 15360, 61440, 983040, 3932160, + * 15728640, 7, 14, 112, 224, 1792, + * 3584, 28672, 57344, 458752, 917504, 7340032, + * 14680064, 3, 12, 48, 192, 768, + * 3072, 12288, 49152, 196608, 786432, 3145728, + * 12582912, + * 4095, 255, 4080, 15, 240, 3840, + * 3, 12, 48, 192, 768, 3072, + * 37*0 / + data eqonly /3*.true.,46*.false.,7*.true.,91*.false./ + ip = 0 + nreal = 0 + itnow = 0 +1 continue + ip = ip+1 + if (ip .gt. nn(ivx)) go to 9 +11 if (nodur(ivx,ip).eq.0) then +c +c Ignore all xtup notes except the last, the one with nodur > 0 . +c Xtups are irrelevant here since they are already all in forced beams. +c Will update itnow by nodur at the END of this loop +c + ip = ip+1 + go to 11 + end if + nreal = nreal+1 + nodue(nreal) = nodur(ivx,ip) + short(nreal) = nodue(nreal).lt.16 .and. + * .not.btest(irest(ivx,ip),0) +c +c Rule out notes that have 'alone'-flag set +c + * .and..not.btest(islur(ivx,ip),18) + ipr(nreal) = ip + itr(nreal) = itnow + if (nodue(nreal) .eq. 1) then +c +c 64th gap +c + if (mod(itnow,2) .eq. 0) then +c +c Start of 32nd gap, lump with following note +c + ip = ip+1 + nodue(nreal) = 1+nodur(ivx,ip) + itnow = itnow+nodue(nreal) + else +c +c End of 32nd gap, lump with preceeding note +c + nreal = nreal-1 + nodue(nreal) = 1+nodue(nreal) + itnow = itnow+1 + end if + else + itnow = itnow+nodur(ivx,ip) + end if + go to 1 +9 continue + ir1 = 1 + itseg = lenbar/ibmrep + do 13 irep = 1 , ibmrep +c +c Set bitmaps for all shorts neighbored by a short. Each bit represents a +c span of 32nd note. maps, mapm, mape record start, full duration, and end +c of consecutive span of beamable (<1/4) notes. +c + maps = 0 + mapm = 0 + mape = 0 + itend = itseg*irep + itoff = itend-itseg + do 2 ir = ir1 , nreal + it2 = itr(ir)+nodue(ir)-2 + if (it2 .ge. itend) then + ir1 = ir + go to 14 + end if +c if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal + if (short(ir).and.((ir.gt.1.and.short(max(ir-1,1))).or. + * (ir.lt.nreal.and.short(ir+1)))) then + ib1 = (itr(ir)-itoff)/2 + ib2 = (it2-itoff)/2 + if (max(ib1,ib2).gt.47 .or. ir.gt.48 .or. + * min(ib1,ib2).lt.0) return +c +c Must have an odd number obe beats in a long bar. Auto-beam won't work +c + nip1(ib1) = ipr(ir) + nip2(ib2) = ipr(ir) +c +c nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip +c + maps = ibset(maps,ib1) + mape = ibset(mape,ib2) + do 3 ib = ib1 , ib2 + mapm = ibset(mapm,ib) +3 continue + end if +2 continue +14 continue + if (mapm .eq. 0) go to 13 +c +c Zero out bits from forced beams +c + maps = iand(maps,not(mapfb(irep))) + mapm = iand(mapm,not(mapfb(irep))) + mape = iand(mape,not(mapfb(irep))) +c +c Compare map with template. +c + do 4 it = 1 , nummask(ibmtyp) + masknow = mask(it,ibmtyp) + if (iand(masknow,mapm) .eq. masknow) then +c +c Find least significant bit in the mask to check start time +c + mtemp = masknow + maskm = masknow + do 5 is1 = 0 , 47 + if (iand(1,mtemp) .eq. 1) go to 6 + mtemp = ishft(mtemp,-1) +5 continue +6 continue + if (iand(ishft(1,is1),maps) .eq. 0) go to 4 +c +c is1 is the bit where the beam starts. Continue shifting to +c find most significant bit in the mask to check ending time +c + do 7 is2 = is1 , 47 + mtemp = ishft(mtemp,-1) + if (iand(1,not(mtemp)) .eq. 1) go to 8 +7 continue +8 continue +c +c is2 is now the bit on which the beam ends. +c + if (iand(ishft(1,is2),mape) .eq. 0) go to 4 +c +c Did we pick out a single note from the middle of a longer sequence? +c + if (nip1(is1) .eq. nip2(is2)) go to 4 +c +c We almost have a beam. Check equality of notes if needed. +c + if (eqonly(it,ibmtyp)) then + do 10 ip = nip1(is1) , nip2(is2) + if (nodur(ivx,ip) .ne. 8) then +c +c There is a non-1/8th note in this beam. Exit if not 2 quarters +c + if (is2-is1 .ne. 15) go to 4 +c +c Beam is 2 quarters long. Check if can split in half. +c + ithalf = 0 + do 20 iip = nip1(is1) , nip2(is2) + ithalf = ithalf+nodur(ivx,iip) + if (ithalf .gt. 16) go to 4 + if (ithalf .eq. 16) go to 21 +20 continue + print*,'Problem in findbeam, please call Dr. Don' + go to 4 +21 continue +c +c Otherwise, split in half by keeping only the first half. Other half will +c be picked up later, assuming masks are listed longest first. +c + is2 = is1+7 +c +c Reset maskm (since only used part of mask), used later to zero out +c bits that contain beams +c + maskm = 0 + do 15 is = is1 , is2 + maskm = ibset(maskm,is) +15 continue + go to 16 + end if +10 continue + end if +16 continue +c +c This is a beam. If last "effective" ends on odd 64th, add 1 more +c +c if (abs(mod(to(iand(255,ipl(ivx,nip2(is2)))) +c * +nodur(ivx,nip2(is2)),2.)) .gt. tol) then + if (abs(amod(to(ipl2(ivx,nip2(is2))) + * +nodur(ivx,nip2(is2))+.5*tol,2.)) .gt. tol) then + nip2(is2) = nip2(is2)+1 + end if + numbms(ivx) = numbms(ivx)+1 + numnew = numbms(ivx) + call logbeam(numnew,nip1(is1),nip2(is2)) +c +c Zero out the appropriate bits so these notes don't get used again +c + mapm = iand(mapm,not(maskm)) + if (mapm.eq.0) go to 13 + maps = iand(maps,not(maskm)) + mape = iand(mape,not(maskm)) + end if +4 continue +13 continue + return + end + subroutine findeonk(nptr1,nptr2,wovera,xelsk,dtmin,dtmax,eonk0) + parameter (nkb=3999,maxblks=4000) +c +c Compute an exponent eonk for use in the "flattened" formula for elemskips +c vs time. We must solve the eqution f = 0. Initial quess is eonk0. +c + logical gotclef + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /comtol/ tol + common /comeon/ eonk,ewmxk + eonk = eonk0 + niter = 0 +1 continue + ewmxk = f1eon(dtmax)**eonk + niter = niter+1 + esum = 0. + desum = 0. + do 2 iptr = nptr1 , nptr2 + targ = durb(iptr)/sqzb(iptr) + esum = esum+nnpd(iptr)*sqzb(iptr)*feon(targ) + detarg = sqrt(targ/2*(dtmax/targ)**eonk)*alog(dtmax/targ) + desum = desum+nnpd(iptr)*sqzb(iptr)*detarg +2 continue + f = wovera*feon(dtmin)-xelsk-esum + fp = wovera*sqrt(dtmin/2*(dtmax/dtmin)**eonk)*alog(dtmax/dtmin) + * -desum + if (abs(fp).lt.tol .or. abs(eonk-.5).gt..5 .or. niter.gt.100) then + call printl( + * 'Error in findeonk. Please send source to Dr. Don') + eonk = 0. + ewmxk = 1. + return + end if + dsoln = -f/fp + if (abs(dsoln) .lt. .1*tol) return +c +c Not converged yet, try again +c + eonk = eonk+dsoln + go to 1 + end + function fnote(nodur,ivx,ip,nacc) +c +c This return the real duration of a note +c + parameter (nm=24) + integer*4 nodur(nm,200),nacc(nm,200) + logical btest + ipback = ip + if (nodur(ivx,ip) .gt. 0) then + if (ip .gt. 1) then +c +c Check if this is last note of xtup +c + if (nodur(ivx,ip-1).eq.0) then + ipback = ip-1 + go to 2 + end if + end if + fnote = nodur(ivx,ip) + return + end if +2 continue +c +c Count back to prior non zero note. Start at ip to avoid neg index if ip=1. +c Count how many doubled xtups notes there are from ip-1 to first note. +c + ndoub = 0 + do 1 ip1m1 = ipback , 1 , -1 + if (nodur(ivx,ip1m1) .gt. 0) go to 4 + if (ip1m1.lt.ip .and. btest(nacc(ivx,ip1m1),18)) ndoub=ndoub+1 +1 continue +4 continue +c +c count forward to next non-0 nodur. Start at ip in case last note of xtup. +c + do 3 iip = ip , 200 +c +c Count doubled xtup notes from ip to end. +c + if (btest(nacc(ivx,iip),18)) ndoub = ndoub+1 + if (nodur(ivx,iip) .gt. 0) then +c fnote = nodur(ivx,iip)/float(iip-ip1m1) + fnote = nodur(ivx,iip)/float(iip-ip1m1+ndoub) + if (btest(nacc(ivx,ip),18)) then + fnote = 2*fnote + else if (btest(nacc(ivx,ip),27)) then + fnote = 1.5*fnote + else if (ip .gt. 1) then + if (btest(nacc(ivx,ip-1),27)) fnote = .5*fnote + end if + return + end if +3 continue + print*,' ' + call printl + * ('Probable misplaced barline or incorrect meter, stopping') +c call printl('Program error in fnote, send source to Dr. Don') + call stop1() + end + subroutine g1etchar(lineq,iccount,charq) + parameter(nm=24) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,issegno,isheadr,isvolt,fbon + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac + character*1 charq + character*128 lineq,lnholdq +c +c Gets the next character out of lineq*128. If pointer iccount=128 on entry, +c then reads in a new line. Resets iccount. Ends program if no more input. +c + if (iccount .eq. 128) then + call read10(lineq,lastchar) + if (lastchar) return + if (.not.endmac) then + iccount = 0 + if (.not.mplay) nline = nline+1 + else + endmac = .false. + iccount = icchold + lineq = lnholdq + end if + if (mrecord) then + call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) + end if + end if + iccount = iccount+1 + charq = lineq(iccount:iccount) + return + end + subroutine g1etnote(loop,ifig,optimize,fulltrans) + parameter (nm=24,nkb=3999,mv=24576,maxblks=4000) + character*1 chax + common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), + * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, + * nbars,itsofar(nm),nib(nm,15),nn(nm), + * rest(nm,200),lenbr0,lenbr1,firstline,newmeter + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + common /compage/ widthpt,ptheight,hoffpt,voffpt, + * nsyst,nflb,ibarflb(0:40), + * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), + * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), + * nistaff(0:40) + common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) + common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1, + * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS + logical lastchar,firstline,rest,loop,newmeter,fbon,issegno,barend, + * isheadr,fulbrp,usefig,isvolt,iskchb,kchmid,plusmin,ornrpt, + * stickyS + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /commus/ musize,whead20 + logical mrecord,mplay,endmac,shifton,gotclef,optimize + character*128 lineq,lnholdq + character*1 charq,dotq,dumq,durq,charlq + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,cdot + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + logical novshrinktop,upslur,fontslur,ztrans, + * WrotePsslurDefaults,cstuplet + common /comnvst/ novshrinktop,cstuplet + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + character*51 literq(3) + common /comligfont/ isligfont + logical isligfont + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + logical fulltrans + common /comsize/ isize(nm) + data literq + * /'Literal TeX string cannot start with 4 backslashes!', + * 'TeX string must have <129 char, end with backslash!', + * 'Type 2 or 3 TeX string can only start in column 1!'/ + cdot = .false. +1 call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') charlq = charq + if (lastchar) then + if (index('/%',charlq) .eq. 0) then + print* + print*,'WARNING:' + print*,'Last non-blank character is "',charlq,'", not "/,%"' + print*,'ASCII code:',ichar(charlq) + write(15,'(/a)')'Last non-blank character is "'//charlq// + * '", not "/,%"' + write(15,'(a11,2x,i3)')'ASCII code:',ichar(charlq) +c +c Append " /" to last line. NB lastchar=.true. => ilbuf=nlbuf+1. +c + ilbuf = ilbuf-1 + lbuf(ilbuf) = lbuf(ilbuf)+2 + bufq = bufq(1:ipbuf)//' /' + write(15,*)'appending <blank>/' + print*,'appending <blank>/' + lineq = lineq(1:iccount)//' /' + lastchar = .false. + go to 1 + end if + return + end if + if (charq .eq. ' ') then + go to 1 + else if (charq.eq.'%' .and. iccount.eq.1) then + iccount = 128 + go to 1 +c +c Replacement 1/22/12 since gfortran 4.7 with -O was choking here! +c +c else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. + else if (index('abcdefg',charq).gt.0 .or. + * charq.eq.'r') then +c +c This is a note/rest. gotclef is only used for checking for clef before "/" +c + if (cdot) go to 28 + if (gotclef) gotclef=.false. + idotform = 0 + numnum = 0 + plusmin = .false. +28 nnl(ivx) = nnl(ivx)+1 + if (nnl(ivx) .gt. 200) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '>200 notes in line of music. Use smaller blocks!') + call stop1() + end if + dotq = 'x' +c +c Check if this is 'r ' and previous note was full-bar-pause +c + fulbrp = charq.eq.'r' .and. lineq(iccount+1:iccount+1) .eq.' ' + * .and. nnl(ivx).gt.1 .and. rest(ivx,max(1,nnl(ivx)-1)) .and. + * nodur(ivx,max(1,nnl(ivx)-1)) .eq. lenbar +2 call g1etchar(lineq,iccount,durq) + ic = ichar(durq) + if (ic.le.57 .and. ic.ge.48) then +c +c Digit +c + if (numnum .eq. 0) then + nnodur = ic-48 + numnum = 1 + go to 2 + else if (numnum .eq. 1) then + if (charq .eq. 'r') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one digit allowed after rest symbol "r"!') + call stop1() + end if + numnum = 2 + if (plusmin) then + print* + print*,'*********WARNING*********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Before version 1.2, +/- was ignored if octave was!') + print*, + * 'explicitly specified. May need to edit old editions' + end if + go to 2 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '>2 digits in note symbol!') + call stop1() + end if + else if (durq.eq.'d') then + dotq = durq + if (lineq(iccount+1:iccount+1) .eq. 'd') then + iddot = 1 + iccount = iccount+1 +c +c Since we flow out, double dots won't work with other dot options +c + end if + if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then +c +c move a dot, provided a number follows. +c + call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,durq) + if (index('0123456789-.',durq) .eq. 0) then +c +c Backup, exit the loop normally +c + iccount = iccount-2 + go to 2 + end if + call readnum(lineq,iccount,dumq,fnum) + if (index('+-',dumq) .gt. 0) then +c +c Vertical shift also +c + call g1etchar(lineq,iccount,durq) + if (index('0123456789-.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected number after 2nd +/- (shift dot)!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + end if + iccount = iccount-1 + end if + go to 2 + else if (index('<>',durq) .gt. 0) then +c +c Accidental shift +c +c if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then + if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, +c * 'Expected "f", "s", or "n" before "<" or ">"!') + * 'Expected "f", "s", "n" or "A" before "<" or ">"!') + call stop1() + end if + ipm = 1 + if (durq .eq. '<') ipm=-1 + call g1etchar(lineq,iccount,durq) + if (index('123456789.0',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected number after </> (accidental shift)!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + fnum = ipm*fnum + if (fnum.lt.-5.35 .or. fnum.gt.1.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Horizontal accidental shift must be >-5.35 and <1.0!') + call stop1() + end if + iccount = iccount-1 + go to 2 + else if (index('+-',durq) .gt. 0) then + if (charq .ne. 'r') then + if (index('fsnA',lineq(iccount-1:iccount-1)) .gt. 0) then + ipm = 1 + if (durq .eq. '-') ipm=-1 + if (index('0123456789',lineq(iccount+1:iccount+1)) + * .gt.0) then +c +c This may be start of accidental shift, but may be octave jump; then duration +c + icsav = iccount + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (index('+-',durq) .gt. 0) then +c +c This is an accid shift since there's a 2nd consecutive signed number. +c Check size of 1st number. +c + if (fnum .gt. 30.5) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Vertical accidental shift must be less than 31!') + call stop1() + end if + ipm = 1 + if (durq .eq. '-') ipm = -1 + call g1etchar(lineq,iccount,durq) + if (index('1234567890.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected 2nd number of accidental shift)!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + fnum = ipm*fnum + if (fnum.lt.-5.35 .or. fnum.gt.1.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Horiz. accidental shift must be >-5.35 and <1.0!') + call stop1() + end if + iccount = iccount-1 + go to 2 + else +c +c Not accid shift, reset, then flow out +c + iccount = icsav + end if + end if + end if + plusmin = .true. + if (numnum .eq. 2) then + print* + print*,'*********WARNING*********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Before version 1.2, +/- was ignored if octave was!') + print*, + * 'explicitly specified. May need to edit old editions' + end if + go to 2 +c +c It's a rest containing +|- . Must refer to a vertical shift. Read past. +c + else + call g1etchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,dum) + iccount = iccount-1 + go to 2 + end if +c else if (index('ulare',durq) .gt. 0) then + else if (index('ularec',durq) .gt. 0) then + go to 2 + else if (durq .eq. 'S') then +c +c Stemlength change +c + call g1etchar(lineq,iccount,durq) + if (index('.0123456789:',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a number or colon here!') + call stop1() + end if + if (durq .eq. ':') then + if (.not.stickyS) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned off sticky stemshrinks without turning on!') + call stop1() + end if + stickyS = .false. + go to 2 + end if + call readnum(lineq,iccount,durq,dum) + if (dum.lt..5 .or. dum.gt.4.) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Stemlength shortening must be from .5 to 4!') + call stop1() + end if + if (durq .ne. ':') then + iccount = iccount-1 + else + if (stickyS) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned on sticky stemshrinks when already on!') + call stop1() + end if + stickyS = .true. + end if + go to 2 + else if (index('fsn',durq) .gt. 0) then +c +c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so +c MUST come right after "f,s,n" +c + if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 + go to 2 + else if (durq .eq. 'p') then + fulbrp = charq.eq.'r' + if (.not. fulbrp) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'The option "p" only works with "r" (rest)!') + call stop1() + end if + go to 2 + else if (durq .eq. 'b') then + if (charq .ne. 'r') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You entered "b"; I expected "rb"!') + call stop1() + else if (numnum .eq. 2) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You entered "r" & "b" with two numbers!') + end if + go to 2 + else if (durq .eq. 'x') then +c +c Xtuplet. Count number of doubled notes (for unequal xtups) +c + if (btest(nacc(ivx,nnl(ivx)),18)) then + ndoub = 1 + else + ndoub = 0 + end if +c +c Will set all durations to 0 except last one. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'First char after "x" in xtuplet must be "1"-"9"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (fnum .gt. 99) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Xtuplet cannot have more than 99 notes!') + call stop1() + else if (index(' DFnd',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only legal characters here are " ","D","F","n"!') + call stop1() + end if +c +c End of mandatory xtup inputs. Check for options. Note D,F,d must precede n. +c + if (index('DF',durq) .gt. 0) then +c +c Double xtup note to make an un= xtup. Here, number already set, but may also +c have used this before number was set. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + ndoub = 1 + call g1etchar(lineq,iccount,durq) + else if (durq .eq. 'd') then + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + call g1etchar(lineq,iccount,durq) + end if + if (durq .eq. 'n') then +c +c Number alteration stuff. After 'n', require '+-123456789fs ', no more 'DF'. +c + numshft = 0 +30 call g1etchar(lineq,iccount,durq) + if (durq .eq. 'f') then + go to 30 + else if (index('+-',durq) .gt. 0) then + numshft = numshft+1 + if (numshft .eq. 3) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only 2 shifts are allowed after "n" in xtup!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character should be a digit or "."!') + call stop1() + end if + call readnum(lineq,iccount,durq,snum) + iccount = iccount-1 + if ((numshft.eq.1 .and. snum.gt.15.1) .or. + * (numshft.eq.2 .and. snum.gt.1.51)) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Shift number after "n" in xtup is out of range!') + call stop1() + end if + go to 30 + else if (durq .eq. 's') then +c +c Slope alteration for bracket +c + call getchar(lineq,iccount,durq) + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'For slope adjustment, this character must be "+" or "-"!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character should be a digit!') + call stop1() + end if + call readnum(lineq,iccount,durq,snum) + iccount = iccount-1 + if (nint(snum) .gt. 15) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slope adjustment cannot exceed 15!') + call stop1() + end if + go to 30 + else if (index('123456789',durq) .gt. 0) then +c +c Unsigned integer => alternate printed number +c + call readnum(lineq,iccount,durq,snum) + if (snum .gt. 15.1) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Alternate xtup number after "n" must be <16!') + call stop1() + end if + iccount = iccount-1 + go to 30 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "n" in xtup!') + call stop1() + end if + end if + ntup = nint(fnum) + do 6 itup = 2 , ntup + nodur(ivx,nnl(ivx)) = 0 + nnl(ivx) = nnl(ivx)+1 +110 call g1etchar(lineq,iccount,durq) + if (durq.eq.' ') then + go to 110 + else if (durq .eq. 'o') then +c +c Ornament in xtup. "o" symbol must come AFTER the affected note +c + call g1etchar(lineq,iccount,dumq) + if (index('(stmx+Tup._)e:>^bc',dumq) .eq. 0 ) then + if (index('fg',dumq) .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Fermata or segno not allowed in xtuplet!') + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal ornament!') + end if + call stop1() + end if + if (dumq .eq. 'T') then +c +c Trill. may be followed by 't' and/or number. read 'til blank +c +29 call g1etchar(lineq,iccount,dumq) + if (dumq .ne. ' ') go to 29 + else if (dumq .eq. 'e') then + call g1etchar(lineq,iccount,dumq) + if (index('sfn?',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "e" in edit. accid. symbol!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq) + else if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '":" must be followed by blank in "o: "!') + call stop1() + else if (.not.ornrpt) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Turned off repeated ornaments before they were on!') + call stop1() + end if + ornrpt = .false. + else + call g1etchar(lineq,iccount,dumq) + end if + if (index('+- :',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in ornament symbol!') + call stop1() + end if + if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '":" must be followed by blank in "o: "!') + call stop1() + else if (ornrpt) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned on repeated ornaments but already on!') + call stop1() + end if + ornrpt = .true. + end if + if (index('+-',dumq) .gt. 0) then + if (index('0123456789',lineq(iccount+1:iccount+1)) + * .eq. 0) then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'There should be an integer here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (durq .eq. ':') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot shift AND repeat an ornament!') + call stop1() + end if +c +c 12/7/03 Allow horizontal shift on any ornament, not just breath and ceas. +c + if (index('+-',durq) .gt. 0) then + if (index('.0123456789',lineq(iccount+1:iccount+1)) + * .eq. 0) then + call errmsg(lineq,iccount+1, + * ibarcnt-ibaroff+nbars+1, + * 'There should be a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + end if + end if + go to 110 + else if (index('st(){}',durq) .gt. 0) then +c +c Slur in xtup +c + iposn = 0 + numint = 0 +15 call g1etchar(lineq,iccount,dumq) + iposn = iposn+1 + if (index('udlbfnht',dumq) .gt. 0) then + if (dumq.eq.'t' .and. durq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot use "t" as an option on a tie!') + call stop1() + end if + go to 15 + else if (index('+-',dumq) .gt. 0) then + numint = numint+1 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (numint .eq. 1) then + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + else if (numint .eq. 2) then + if (abs(fnum).gt.6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in the range (-6.3,6.3)!') + call stop1() + end if + else +c +c Third signed integer, must be a midslur or curve spec. +c + if (abs(fnum).gt.31) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur midheight must be in the range (-31,31)!') + call stop1() + end if + if (durq .eq. ':') then +c +c Expecting curve parameters. Get two numbers +c + do 40 i = 1 , 2 + iccount = iccount+1 + fnum = ichar(lineq(iccount:iccount))-48 + if (abs(fnum-3.5) .gt. 3.6) then + call errmsg(lineq,iccount, + * ibarcnt-ibaroff+nbars+1, + * 'Slur curve parameter must be in range (0,7)!') + call stop1() + end if +40 continue + iccount = iccount+1 + end if + end if + iccount = iccount-1 + go to 15 + + else if (dumq .eq. 's') then +c +c What follows should be one or two signed numbers for adjustment of line break +c slur, end of 1st segment or start of second. +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'May not use linebreak slur options with font-based slurs!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character must be "+" or "-"!') + call stop1() + end if + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + if (index('+-',dumq) .gt. 0) then + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (abs(fnum) .gt. 6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in range (-6.3,6.3)!') + call stop1() + end if + end if + iccount = iccount-1 + go to 15 + else if (dumq .eq. 'H' .and. iposn.gt.1) then + if (lineq(iccount+1:iccount+1) .eq. 'H') + * iccount=iccount+1 + go to 15 + else if (dumq .eq. 'p') then +c +c local change in postscript slur/tie adjustment default +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must use postscript slurs ("Ap") to use this option!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "+" or "-" here!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('st',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "s" or "t" here!') + call stop1() + end if + go to 15 + else if (dumq .ne. ' ') then + ic = ichar(dumq) + if ((ic.ge.48.and.ic.le.57) .or. + * (ic.ge.65.and.ic.le.90)) then + if (iposn .eq. 1) then + if (durq.eq.'t' .and. fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID not allowed on non-postscript tie!') + call stop1() + end if + go to 15 + end if + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID must be 2nd character in slur symbol!') + call stop1() + end if + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in slur symbol!') + call stop1() + end if + go to 110 + else if (index('0123456789#-nx_',durq) .gt. 0) then +c +c We have a figure. Only allow on 1st note of xtup +c + if (itup .ne. 2) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Figure in xtup only allowed on 1st note!') + call stop1() + else if (durq.eq.'x') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'No floating figures in xtuplets!') + call stop1() + end if + if (usefig .and. ivx.eq.1) ifig = 1 +26 call g1etchar(lineq,iccount,durq) + if (index('0123456789#-n_.:',durq) .gt. 0) then + go to 26 + else if (durq .eq. 's') then + isligfont = .true. + go to 26 + else if (durq .eq. '+') then +c +c vertical offset, must be integer then blank +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .ne. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Integer for vertical offset expected here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Vertical offset must terminate figure!') + call stop1() + end if + iccount = iccount-1 + go to 26 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in figure in xtuplet!') + call stop1() + end if + go to 110 + else if (durq .eq. 'G') then + ngr = 1 +79 call g1etchar(lineq,iccount,charq) + if (index('123456789',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + ngr = nint(fnum) + iccount = iccount-1 + go to 79 + else if (index('AWulxs',charq) .gt. 0) then + go to 79 + else if (charq .eq. 'm') then + call g1etchar(lineq,iccount,charq) + if (index('01234',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A digit less than 5 must follow "m" in a grace note!') + call stop1() + end if + go to 79 + else if (charq .eq. 'X') then +c +c Space before main note +c + call g1etchar(lineq,iccount,charq) + if (index('0123456789.',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 79 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A number must follow "X" in a grace note!') + call stop1() + end if + end if +c +c At this point, charq is first note name in rest (grace?) +c + do 71 igr = 1 , ngr + numnum = 0 + if (igr .gt. 1) then +75 call g1etchar(lineq,iccount,charq) + if (charq .eq. ' ') go to 75 + end if + if (index('abcdefg',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In grace, expected "a"-"g"!') + call stop1() + end if +78 call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') then + if (index('1234567',charq) .gt. 0) then + if (numnum .eq. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one of "+-1234567" allowed here in grace!') + call stop1() + end if + numnum = 1 + go to 78 + else if (index('+-nfs',charq) .gt. 0) then + go to 78 + end if +c +c Digits are possible octave numbers +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after note name in grace!') + call stop1() + end if +71 continue + go to 110 + else if (durq .eq. chax(92)) then + call chklit(lineq,iccount,literr) + if (literr .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * literq(literr)) + call stop1() + end if + go to 110 + else if (durq .eq. 'M') then +c +c Temporary trap until I get around putting this in pmxb +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Macros not yet allowed in xtuplets!') + call stop1() + else if (durq .eq. 'X') then + call g1etx(lineq,iccount,.false.,shifton, + * ibarcnt-ibaroff+nbars+1,udsp(ibarcnt+nbars+1),wheadpt) + go to 110 + else if (durq .eq. 'z') then +c +c Chord note in xtup. Read past for now. +c +33 call g1etchar(lineq,iccount,durq) + if (durq .ne. ' ') go to 33 + go to 110 + else if (durq .eq. 'D') then +c +c Dynamic mark +c + call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1) + go to 110 + else if (durq .eq. '%') then + if (iccount .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Comment must have "%" in column 1!') + call stop1() + end if + iccount = 128 + go to 110 + else if (durq .eq. '?') then + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + go to 110 + end if + if (durq .ne. '-') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting "-"') + call stop1() + end if + call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting number') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 110 +c+++ + else if (durq.eq.']' .and. lineq(iccount+1:iccount+1).eq.'[' + * .and. lineq(iccount+2:iccount+2).eq.' ') then + iccount = iccount+2 + go to 110 +c+++ + end if +c +c End of xtup options. At this point symbol can only be note or rest +c + if (index('abcdefgr',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In xtup, this character is not allowed!') + call stop1() + else if (durq.eq.'r' .and. itup.eq.ntup) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Sorry, PMX cannot end an xtuplet with a rest!') + call stop1() + end if +7 call g1etchar(lineq,iccount,durq) + if (index('2345678ulcb',durq) .gt. 0) then + go to 7 + else if (index('sfn',durq) .gt. 0) then +c +c Check for MIDI-only accidental. Cannot coexist with accid. pos'n shift. +c + if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 + go to 7 + else if (index('+-<>',durq) .gt. 0) then +c +c May have either octave jump or shifted accid. on main xtup note +c + if (index('+-',durq).gt.0 .and. + * index('01234567890',lineq(iccount+1:iccount+1)).eq.0) + * go to 7 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 7 + else if (index('DF',durq) .gt. 0) then +c +c Double an xtup note to make an unequal xtup +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + ndoub = ndoub+1 + go to 7 + else if (durq .eq. 'd') then + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + go to 7 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal option on xtuplet note!') + call stop1() + end if + if (itup .eq. ntup-ndoub) go to 3 +6 continue +3 continue +c +c 6==End of loop for xtuplet input +c + else if (durq .eq. 'm') then +c +c Multi-bar rest: next 1 or two digits are # of bars. +c + if (mod(itsofar(iv),lenbar) .ne. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Multibar rest must start at beginning of bar!') + call stop1() + else if (iv.eq.1.and.ibarmbr.gt.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Multibar rest only OK at one time per block!') + call stop1() + end if +c +c For some purposes, pretend its one bar only +c + nodur(iv,nnl(iv)) = lenbar + ibarmbr = nbars+1 + mbrest = 0 +c20 call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected an integer after "rm"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + mbrest = nint(fnum) + iccount = iccount-1 +c if (ichar(durq).ge.48.and.ichar(durq).le.57) then +c mbrest = 10*mbrest+ichar(durq)-48 +c go to 20 +c end if + if (nv .gt. 1) then + if (iv .eq. 1) then + mbrestsav = mbrest + else + if (mbrest .ne. mbrestsav) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must enter same multi-bar rest in every voice!') + call stop1() + end if + end if +c +c Zero out mbrestsav so can check at end of input block whether +c all voices have one +c + if (iv .eq. nv) mbrestsav=0 + end if + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "rm"!') + call stop1() + end if + else if (durq .eq. '.') then +c +c Dotted pattern. Close out note. Mult time by 3/4. +c Set time for next note to 1/4. Start the note. +c + idotform = 1 + else if (durq .eq. ',') then + idotform = 3 +c +c Now flow to duration setting, as if durq=' ' +c + else if (index('oL',durq) .gt. 0) then +c +c Suppress full bar rest, or look left for height +c + if (charq .ne. 'r') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"o","L" options only legal for rest, not note!') + call stop1() + end if + go to 2 + else if (index('DF',durq) .gt. 0) then +c +c Double note for xtup. Must check here in case "D" or "F" came before "x" or on +c last note of xtup. Need to flag it in pmxa since affects horiz. spacing. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + go to 2 + else if (durq .eq. 'A') then +c +c Main note accidental option +c + call getchar(lineq,iccount,durq) + if (index('o+-<>',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"o",+","-","<",">" are the only legal options here!') + call stop1() + end if +c +c Need more stuff here +c + if (durq .ne. "o") then +c +c Back up 1, flow out, will get +|-|<|> next loop preceded by "A", and will +c proceed to number input checking +c + iccount = iccount-1 + end if + go to 2 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character!') + print*,'ASCII code:',ichar(durq) + call stop1() + end if +c +c End of block for note options. +c +c Set the duration +c + if (idotform .gt. 0) then + if (idotform .eq. 1) then + nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)*3/2 + else if (idotform .eq. 2) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3 + else if (idotform .eq. 3) then + nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq) + else if (idotform .eq. 4) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2 + end if + else if (ibarmbr.ne.nbars+1 .and. .not.fulbrp) then + nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq) +c +c Check for double dot +c + if (iddot .eq. 1) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6 + iddot = 0 + end if + else if (fulbrp) then + nodur(ivx,nnl(ivx)) = lenbar +c +c Use a one-line function to set nnodur. It gives inverse of ifnodur. +c + nnodur = index('62514x0x37', + * chax(48+int(log(.1+lenbar)/.69315)))-1 + fulbrp = .false. + end if + rest(ivx,nnl(ivx)) = charq.eq.'r' +c +c If inside forced beam, check if note is beamable +c + if (fbon) then + if (nodur(ivx,nnl(ivx)) .lt. 16) go to 120 + if (nnl(ivx) .gt. 1) then + if (nodur(ivx,nnl(ivx)-1) .eq. 0) go to 120 + end if + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Unbeamable thing in forced beam!') + call stop1() + end if +120 continue +c +c Get number of prior bars for later check on whether note spans bar line +c + nbb4 = itsofar(ivx)/lenbar + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + if (mod(itsofar(ivx),lenbar) .eq. 0) then + nbars = nbars+1 + if (shifton) barend = .true. +c +c Will check barend when 1st note of next bar is entered. +c + if (nbars .gt. 15) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot have more than 15 bars in an input block!') + call stop1() + end if + nib(ivx,nbars) = nnl(ivx) + if (firstline .and. lenbar.ne.lenbr1) then +c +c Just finished the pickup bar for this voice. +c + if (itsofar(ivx) .ne. lenbr0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Pickup bar length disagrees with mtrnum0!') + call stop1() + end if + lenbar = lenbr1 + itsofar(ivx) = 0 + end if + else if (barend) then + if (shifton) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar ended with user-defined shift still on!') + call stop1() + end if + barend = .false. + else if (itsofar(ivx)/lenbar .gt. nbb4) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'This note spans a bar line!') + call stop1() + end if + if (idotform.eq.1 .or. idotform.eq.3) then + call g1etchar(lineq,iccount,charq) + if (index('abcedfgr',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected note name or "r" here!') + call stop1() + end if + idotform = idotform+1 + numnum = 1 + go to 28 + end if +c +c End of sub block for note-rest +c + else if (charq .eq. 'z') then + call g1etchar(lineq,iccount,charq) + if (index('abcdefg',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected chord note name here!') + call stop1() + end if +25 call g1etchar(lineq,iccount,durq) +c if (index('dre12345678',durq) .gt. 0) then + if (index('dre12345678c',durq) .gt. 0) then + go to 25 + else if (index('fsn',durq) .gt. 0) then +c +c Check for midi-only accid. CANNOT coesist with accidental position tweaks, so +c MUST come right after "f,s,n" +c + if (lineq(iccount+1:iccount+1) .eq. 'i') iccount=iccount+1 + go to 25 + else if (durq .eq. 'A') then + if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Must have "f,s,n" before "A" in chord note!') + call stop1() + end if + go to 25 + else if (index('<>',durq) .gt. 0) then + if (index('fsnA',lineq(iccount-1:iccount-1)) .eq. 0) then +c if (index('fsncA',lineq(iccount-1:iccount-1)) .eq. 0) then ! Causes problems + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Must have "f,s,n,A" before "<" or ">"!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('1234567890.',durq) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Expected a number to start here for accidental shift!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 25 + else if (index('+-',durq) .gt. 0) then + if (index('1234567890.',lineq(iccount+1:iccount+1)) .eq. 0) + * go to 25 +c +c Number or '.' (durq) follows +/- . Get it. +c + call g1etchar(lineq,iccount,durq) + if (durq .eq. '.' .and. index('1234567890', + * lineq(iccount+1:iccount+1)) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * '"." here must be followed by a digit!') + call stop1() + else if (index('sfndA',lineq(iccount-2:iccount-2)).eq.0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Number after +/- must follow "d,s,f,n,A"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (index('+-',durq) .eq. 0) then + iccount = iccount-1 + go to 25 + end if +c +c 2nd +/- +c + call g1etchar(lineq,iccount,durq) + if (durq .eq. '.') call g1etchar(lineq,iccount,durq) + if (index('1234567890',durq) .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Expected a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 25 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in chord note!') + call stop1() + end if + else if (charq .eq. 'G') then + ngr = 1 +9 call g1etchar(lineq,iccount,charq) + if (index('123456789',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + ngr = nint(fnum) + iccount = iccount-1 + go to 9 + else if (index('AWulxs',charq) .gt. 0) then + go to 9 + else if (charq .eq. 'm') then + call g1etchar(lineq,iccount,charq) + if (index('01234',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A digit less than 5 must follow "m" in a grace note!') + call stop1() + end if + go to 9 + else if (charq .eq. 'X') then +c +c Space before main note +c + call g1etchar(lineq,iccount,charq) + if (index('0123456789.',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 9 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A number must follow "X" in a grace note!') + call stop1() + end if + end if +c +c At this point, charq is first note name in rest (grace?) +c + do 19 igr = 1 , ngr + numnum = 0 + if (igr .gt. 1) then +55 call g1etchar(lineq,iccount,charq) + if (charq .eq. ' ') go to 55 + end if + if (index('abcdefg',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In grace, expected "a"-"g"!') + call stop1() + end if +18 call g1etchar(lineq,iccount,charq) + if (charq .ne. ' ') then + if (index('1234567',charq) .gt. 0) then + if (numnum .eq. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one of "+-1234567" allowed here in grace!') + call stop1() + end if + numnum = 1 + go to 18 +c else if (index('nfs',charq) .gt. 0) then + else if (index('+-nfs',charq) .gt. 0) then + go to 18 + end if +c +c Digits are possible octave numbers +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after note name in grace!') + call stop1() + end if +19 continue + else if (charq .eq. chax(92)) then + call chklit(lineq,iccount,literr) + if (literr .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * literq(literr)) + call stop1() + end if + else if (charq .eq. 'o') then +c +c Ornament on non-xtup note. "o" symbol must come AFTER the affected note +c + if (nnl(ivx) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"o" must be in same input block, after affected note!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('(stmgx+Tupf._)e:>^bc',dumq) .eq. 0 ) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal ornament!') + call stop1() + end if + if (dumq .eq. ':') then + call g1etchar(lineq,iccount,dumq) + if (dumq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected blank after "o:"!') + call stop1() + else if (.not.ornrpt) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Turned off repeated ornaments before they were on!') + call stop1() + end if + ornrpt = .false. + else if (dumq .eq. 'g') then + if (issegno) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Sorry, only one "segno" per input block!') + call stop1() + else if (ivx .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'segno can only be in voice 1!') + call stop1() + end if + issegno = .true. +12 call g1etchar(lineq,iccount,dumq) + if (dumq.eq.'-' .or. + * (ichar(dumq).ge.48.and.ichar(dumq).le.58)) go to 12 + if (dumq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in segno ornament symbol!') + call stop1() + end if + else if (dumq .eq. 'T') then +c +c Trill. may be followed by 't' and/or number. read 'til blank +c +22 call g1etchar(lineq,iccount,dumq) + if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected blank after ":"!') + call stop1() + end if + go to 32 + else if (dumq .ne. ' ') then + go to 22 + end if + else if (dumq .eq. 'f') then + call g1etchar(lineq,iccount,dumq) + if (index(' d+-:',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "f" in fermata ornament symbol!') + call stop1() + end if + if (dumq .eq. 'd') call g1etchar(lineq,iccount,dumq) + if (dumq .eq. ':') go to 32 + else if (dumq .eq. 'e') then + call g1etchar(lineq,iccount,dumq) + if (index('sfn?',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "e" in edit. accid. symbol!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq) + else + call g1etchar(lineq,iccount,dumq) + end if + if (index('+- :',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in ornament symbol!') + call stop1() + end if + if (index('+-',dumq) .gt. 0) then + if (index('0123456789',lineq(iccount+1:iccount+1)).eq.0) then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'There should be an integer here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (durq .eq. ':') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot shift AND repeat an ornament!') + call stop1() + end if +c +c 12/7/03 Allow horizontal shift on any ornament, not just breath and caes. +c + if (index('+-',durq) .gt. 0) then + if (index('.0123456789',lineq(iccount+1:iccount+1)) + * .eq. 0) then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'There should be a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + end if + end if +32 continue + if (dumq .eq. ':') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '":" must be followed by blank in "o: "!') + call stop1() + else if (ornrpt) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Turned on repeated ornaments but already on!') + call stop1() + end if + ornrpt = .true. + end if + else if (index('st(){}',charq) .gt. 0) then + numint = 0 + iposn = 0 +8 call g1etchar(lineq,iccount,dumq) + iposn = iposn+1 + if (charq.eq.'t' .and. dumq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot use "t" as an option on a tie!') + call stop1() + end if + if (index('udltb+-fnhHps ',dumq) .eq. 0) then +c +c Check for explicit ID code. +c + ic = ichar(dumq) + if (ic.lt.48 .or. (ic.gt.57.and.ic.lt.65) .or. + * ic.gt.90) then +c +c Not 0-9 or A-Z, so exit +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in slur symbol!') + call stop1() + else +c +c It is a possible ID code. Right place? +c + if (iposn .ne. 1) then +c +c Slur ID is not 2nd! +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID must be second character in slur symbol!') + call stop1() + else if (charq.eq.'t' .and. fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur ID not allowed on non-postscript tie!') + call stop1() + end if + end if +c +c Slur ID is OK. Note it cannot be "H" at this point.. +c + go to 8 + else if (dumq .eq. 'H') then + if (iposn .eq. 1) go to 8 +c +c "H" is NOT an ID code. +c + if (.not.fontslur .and. charq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot reshape postscript ties this way!') + call stop1() + end if + if (lineq(iccount+1:iccount+1) .eq. 'H') then + iccount=iccount+1 + iposn = iposn+1 + end if + go to 8 + else if (index('fh',dumq).gt.0 .and. .not.fontslur + * .and. charq.eq.'t') then +c +c 3/9/03 Can't reshape postscript tie. +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot reshape postscript ties this way!') + call stop1() + else if (dumq .eq. 'p') then +c +c local change in postscript slur/tie adjustment default +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must use postscript slurs ("Ap") to use this option!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "+" or "-" here!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('st',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "s" or "t" here!') + call stop1() + end if + iposn = iposn+2 + go to 8 + end if + if (index('udltbfnh',dumq) .gt. 0) then + go to 8 + else if (index('+-',dumq) .gt. 0) then + numint = numint+1 + if (fontslur .and. charq.eq.'t') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"+|-" for slur height only allowed in "s"-slurs!') + call stop1() + end if + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (numint .eq. 1) then + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + else if (numint .eq. 2) then + if (abs(fnum) .gt. 6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in range (-6.3,6.3)!') + call stop1() + end if + else +c +c Third signed integer, must be a midslur or curve spec. +c + if (abs(fnum).gt.31) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur midheight must be in the range (-31,31)!') + call stop1() + end if + if (durq .eq. ':') then +c +c Expecting curve parameters. Get two numbers +c + do 41 i = 1 , 2 + iccount = iccount+1 + fnum = ichar(lineq(iccount:iccount))-48 + if (abs(fnum-3.5) .gt. 3.6) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Slur curve parameter must be in range (0,7)!') + call stop1() + end if +41 continue + iccount = iccount+1 + end if + end if + iccount = iccount-1 + go to 8 + else if (dumq .eq. 's') then +c +c What follows should be one or two signed numbers for adjustment of line break +c slur, end of 1st segment or start of second. +c + if (fontslur) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'May not use linebreak slur options with font-based slurs!') + call stop1() + end if + call g1etchar(lineq,iccount,dumq) + if (index('+-',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character must be "+" or "-"!') + call stop1() + end if + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (nint(fnum) .gt. 30) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Magnitude of slur height adjustment cannot exceed 30!') + call stop1() + end if + if (index('+-',dumq) .gt. 0) then + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (abs(fnum) .gt. 6.3) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Slur horiz shift must be in range (-6.3,6.3)!') + call stop1() + end if + end if + iccount = iccount-1 + go to 8 + else if (dumq .eq. 'H' .and. iposn.gt.1) then + if (lineq(iccount+1:iccount+1) .eq. 'H') iccount=iccount+1 + go to 8 + end if + else if (charq .eq. '?') then + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + else + if (durq .ne. '-') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting "-"!') + call stop1() + end if + call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expecting number!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + end if + else if ((ichar(charq).ge.48.and.ichar(charq).le.57) .or. + * index('#-nx_',charq) .gt. 0) then +c +c We have a figure. Must come AFTER the note it goes under +c + if (itsofar(ivx).eq.0 .and. + * (.not.firstline.or.lenbr0.eq.0.or.lenbar.eq.lenbr0)) then +c +c Figure before first note in block +c + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot put figure before first note in block!') + call stop1() + end if + if (charq.eq.'x') then + indxb = index(lineq(iccount:128),' ') + if (indxb .lt. 5) then + call errmsg(lineq,iccount+indxb-1,ibarcnt-ibaroff+nbars+1, + * 'Cannot have a blank here in floating figure!') + call stop1() + end if + end if + if (usefig) ifig = 1 +5 call g1etchar(lineq,iccount,charq) + if (index(' 0123456789#-nx_.:+s',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in figure!') + call stop1() + else if (charq .eq. '+') then +c +c vertical offset, must be integer, then blank +c + call g1etchar(lineq,iccount,charq) + if (index('123456789',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Integer for vertical offset expected here!') + call stop1() + end if + call readnum(lineq,iccount,charq,fnum) + if (charq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Vertical offset must terminate figure!') + call stop1() + end if + iccount = iccount-1 + go to 5 + else if (charq .eq. 's') then + isligfont = .true. + end if + if (charq .ne. ' ') go to 5 + else if (charq .eq. '[') then + if (fbon) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Started forced beam while another was open!') + call stop1() + end if + fbon = .true. +17 call g1etchar(lineq,iccount,charq) + if (index('uljhf:',charq) .gt. 0) then + go to 17 + else if (index('+-',charq) .gt. 0) then + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + go to 17 + else if (charq .eq. 'm') then +c +c Forced multiplicity, next char should be 1-4 +c + call g1etchar(lineq,iccount,charq) + if (index('1234',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Forced multiplicity for a beam must be 1, 2, 3, or 4!') + call stop1() + end if + go to 17 + else if (charq .ne. ' ') then + if (index('0123456789',charq) .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'After "[", digits must now be preceeded by "+" or "-"!') + print*,'You will have to edit older sources to meet this rqmt,' + print*,'but it was needed to allow 2-digit height adjustments.' + print*,'Sorry for the inconvenience. --The Management' + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after [!') + end if + call stop1() + end if + else if (charq .eq. ']') then + if (.not.fbon) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Forced beam stop with no corresponding start!') + call stop1() + end if + call g1etchar(lineq,iccount,charq) + if (charq .eq. '-') then + if (lineq(iccount+1:iccount+2) .ne. '[ ') then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'Only sequence allowed here is "[ "!') + call stop1() + else + iccount = iccount+2 + end if + else if (charq .eq. '[') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'This character must be a blank!') + call stop1() + end if + else +c +c Forced beam is really ending +c + fbon = .false. + if (charq .eq. 'j') then + if (lineq(iccount+1:iccount+1) .ne. ' ') then + call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, + * 'This character must be a blank!') + call stop1() + end if + else if (charq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"]" must be followed by blank, "j", "-", or "["!') + call stop1() + end if + end if + else if (charq .eq. 'D') then +c +c Dynamic mark +c + if (nnl(ivx) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"D" must not come before any notes have been entered!') + call stop1() + end if + call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1) + else if (index('lhw',charq) .gt. 0) then +c +c Save position for later check +c + icclhw = iccount + call g1etchar(lineq,iccount,durq) + if (index('0123456789.+- ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "l", "w", or "h"!') + call stop1() + end if + isheadr = isheadr .or. charq .eq. 'h' + if (index(' +-',durq) .gt. 0) then +c +c There is a header (or lower string?) +c + if (index('+-',durq) .gt. 0) then +c +c User-defined vert offset (\internote). +c + if (charq .ne. 'h') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"+" or "-" not permitted here!') + call stop1() + end if +c +c Have "h" followed by +/- . Check for digit. +c Can blow durq since not using fnum for now, but... +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a digit here!') + call stop1() + end if +c +c Have "h" followed by +/- followed by a digit. No need to get the number. +c +c call readnum(lineq,iccount,durq,fnum) + end if + if (charq .ne. 'w') then +c +c Header or lower string. +c + if (icclhw .ne. 1) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * '"h" or "l" must be first character in line!') + call stop1() + end if +c +c Read past the next line, which has the string. +c + call read10(charq,lastchar) + nline = nline+1 + iccount = 128 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Symbol "w" (width) must be followed by a digit!') + call stop1() + end if + else +c +c Height or width change spec. Check if at start of piece. +c + if (ibarcnt .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Symbol must go at top of first input block!') + call stop1() + end if + call readnum(lineq,iccount,durq,dimen) +c +c Check units. Convert to points +c + if (durq .eq. ' ' .or. durq .eq. 'p') then + dimen = dimen+.5 + else if (durq .eq. 'i') then + dimen = dimen*72+.5 + else if (durq .eq. 'm') then + dimen = dimen/25.4*72+.5 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal unit; must be "p","i",or"m"!') + call stop1() + end if + if (charq .eq. 'h') then + ptheight = int(dimen) + else + widthpt = int(dimen) + end if + end if + else if (charq .eq. 'm') then +c +c Time signature change. Only allow at beginning of block. +c mtrnuml, mtrdenl (logical) and p (printable) will be input. +c mtrnuml=0 initially. (In common) +c +c Check whether at beginning of a block +c + if (ivx.ne.1 .or. nnl(1).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Meter change only OK in voice 1, at start of block!') + print*,'voice number is',ivx + call stop1() + end if + newmeter = .true. + call readmeter(lineq,iccount,mtrnuml,mtrdenl) + if (mtrnuml .eq. 0) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Digit 0 not allowed here!') + call stop1() +c else if (mtrdenl .eq. 1) then +cc +cc Kluge!!! +cc +c mtrdenl = 2 +c mtrnuml = 2*mtrnuml + end if + call readmeter(lineq,iccount,mtrnmp,mtrdnp) +c +c Read past printed time signature; not used in pmxa. +c + lenbeat = i1fnodur(mtrdenl,'x') + lenmult = 1 + if (mtrdenl .eq. 2) then + lenbeat = 16 + lenmult = 2 + end if + lenbar = lenmult*mtrnuml*lenbeat + mtrnuml = 0 + else if (charq .eq. 'C') then + call g1etchar(lineq,iccount,durq) + if (.not.(index('tsmanrbf',durq).gt.0 .or. +c * (ichar(durq).ge.48 .and. ichar(durq).le.54))) then + * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Must have t,s,m,a,n,r,b,f or 1-6 after C!') + * 'Must have t,s,m,a,n,r,b,f or 1-7 after C!') + call stop1() + end if + gotclef = .true. + else if (charq .eq. 'R') then + if (ivx .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Repeats can only go in voice 1!') + call stop1() + end if +10 call g1etchar(lineq,iccount,durq) + if (index('lrdDbz',durq) .gt. 0) go to 10 + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "R" (repeat/double bar)!') + call stop1() + end if + else if (charq .eq. 'V') then +c +c Ending +c + if (iv .ne. 1) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Voltas are only allowed in voice #1!') + call stop1() + else if (isvolt) then + print* + print*,'*******WARNING********' + write(15,'(/,a)')'*******WARNING********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There is more than one volta in this input block.!') + print*,'This may work in a score, but WILL NOT work in parts.' + print*, + *'Safest to have only 1 volta per block, at the start of the block' + write(15,'(a)') + * 'This may work in a score, but WILL NOT work in parts.' + write(15,'(a)') + *'Safest to have only 1 volta per block, at the start of the block' + end if + isvolt = .true. + lvoltxt = 0 +11 call g1etchar(lineq,iccount,durq) + if (durq .ne.' ') then + go to 11 + end if + else if (charq .eq. 'B') then + continue + else if (charq .eq. 'P') then + if (ivx.ne.1 .or. nnl(1).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only allowed at beginning of block!') + call stop1() + end if +16 call g1etchar(lineq,iccount,durq) + if (durq.eq.'l'.or.durq.eq.'r'.or.(ichar(durq).ge.48 .and. + * ichar(durq).le.57)) go to 16 + if (durq .eq. 'c') then +c +c Expect a centered name, and it has to be last option +c + call g1etchar(lineq,iccount,durq) + if (durq .eq. '"') then +c +c Quoted name, go to next quote mark +c + do 35 iccount = iccount+1 , 127 + if (lineq(iccount:iccount) .eq. '"') go to 36 +35 continue + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Missing close quote after page number command (P)!') + call stop1() +36 continue + else if (durq .ne. ' ') then +c +c Space-delimited name, look for next blank +c + do 37 iccount = iccount+1 , 127 + if (lineq(iccount:iccount) .eq. ' ') go to 38 +37 continue +38 continue + end if + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only "l","r","c" or digit allowed after "P"!') + call stop1() + end if + else if (charq .eq. 'W') then + call g1etchar(lineq,iccount,durq) + if (index('.0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a number to start here!') + call stop1() + end if + call readnum(lineq,iccount,durq,wminnh(ibarcnt+nbars+1)) + else if (charq .eq. 'T') then +c +c Titles +c + call g1etchar(lineq,iccount,durq) + if (index('itc',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must put "i", "t", or "c" after "T"!') + call stop1() + end if + ihead = ihead+2**(index('itc',durq)-1) +c +c Maybe a number after 'Tt', but ignore here. Read past string on next line. +c + call read10(charq,lastchar) + nline = nline+1 + iccount = 128 + else if (charq .eq. 'A') then +27 call g1etchar(lineq,iccount,durq) + if (index('rbsdeK',durq) .gt. 0) then + go to 27 + else if (durq .eq. 'v') then + if (ibarcnt .eq. 0) novshrinktop = .true. + go to 27 + else if (durq .eq. 'a') then + call g1etchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,fbar) + iccount = iccount-1 + go to 27 + else if (durq .eq. 'i') then + call g1etchar(lineq,iccount,durq) +c +c Local interstaff correction. Set to -1. if not specifiec, or after use, +c or anytime except at top, since pmxb handles all times except at top. +c + call readnum(lineq,iccount,durq,tintstf) + if (ibarcnt .eq. 0) fintstf = tintstf + iccount = iccount-1 + go to 27 + else if (durq .eq. 'I') then +c +c Global interstaff correction. Use in place of fintstf if fintstf<0 +c + call g1etchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,gintstf) + iccount = iccount-1 + go to 27 + else if (durq .eq. 'o') then + optimize = .true. + go to 27 + else if (durq .eq. 'S') then + do 50 iiv = 1 , nv + call g1etchar(lineq,iccount,durq) + if (index('-0st',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'After "AS", need nv instances of "s,t,-,0"!') + call stop1() + end if + if (durq.eq.'-'.or.durq.eq.'s') then + isize(iiv) = 1 + else if (durq.eq.'t') then + isize(iiv) = 2 + end if +50 continue + go to 27 + else if (durq .eq. 'p') then + fontslur = .false. +42 continue + call g1etchar(lineq,iccount,durq) + if (index('+-',durq) .gt. 0) then +c +c Characters to change defaults for ps slurs +c + call g1etchar(lineq,iccount,durq) + if (index('shtc',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only letters allowed here are "s","h","t","c"!') + call stop1() + end if +c +c Now check for another default modifier +c + go to 42 + else if (index('lh',durq) .gt. 0) then +c +c Flags for optional linebreak ties or header specials +c + go to 42 + else + iccount = iccount-1 + end if + go to 27 + else if (durq .eq. 'N') then +c +c Override default name for a part file. Must have part number, then +c partname in quotes. Must be on line by itself, and start in column 1. +c Will only be passed thru to scor2prt. +c + if (iccount .ne. 2) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"AN" must start in column 1!') + call stop1() + end if + ndxquote = index(lineq,'"') + if (ndxquote.lt.4 .or. ndxquote.gt.5 .or. + * index('123456789',lineq(3:3)).eq.0 .or. + * (ndxquote.eq.5.and.index('012',lineq(4:4)).eq.0)) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"AN" must be followed by inst. #, then quote!') + call stop1() + end if + ndxquote = index(lineq(ndxquote+1:128),'"') + if (ndxquote .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'In "AN", file name must be in quotes!') + call stop1() + end if + iccount = 128 + else if (durq .eq. 'T') then + cstuplet = .true. + else if (durq .eq. 'R') then +c +c Get full name of normal include file; must occupy remainder of line +c + call getpmxmod(.false.,lineq(iccount+1:128)) + iccount = 128 + else if (durq .eq. 'c') then + call g1etchar(lineq,iccount,durq) + if (index('l4',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only "l" or "4" is allowed here!') + call stop1() + end if + if (durq .eq. 'l' ) then + hoffpt = -25 + voffpt = -45 + else if (durq .eq. '4') then + ptheight = 745 + widthpt = 499 + hoffpt = -24 + voffpt = -24 + end if + go to 27 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'After "A" must follow one of the letters abcdeiINprRsST!') + call stop1() + end if + else if (charq .eq. 'K') then +c +c Rules and function of K command +c +c Only 1 K +/-n +/-m allowed per block if n.ne.0 (transposition). isig1 is +c initial sig, and must be passed to pmxb because it is needed when topfile +c is called, which is before the K+n+m command is read in pmxb. Also, we +c compute and save ibrkch and newkey for each syst, accounting for key changes, +c then adjust fbar to make poenom much more accurate. +c Jan 02: Now K-0+[n] is used to transpose e.g. from f to f#. +c + call g1etchar(lineq,iccount,durq) + if (index('+-i',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"K" (transpose or key change) must be followed by "+,-,i"!') + call stop1() + end if + if (durq .ne. 'i') then +c +c Normal key change and/or transposition) +c +c iccount = iccount+1 + num1 = 44-ichar(durq) +c +c num1= +1 or -1 +c + ztrans = num1.eq.-1 + call g1etchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st +/- must be followed by a number!') + call stop1() + end if +c iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + num1 = nint(fnum)*num1 + ztrans = ztrans .and. num1.eq.0 + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st number after "K" must be followed by "+,-"!') + call stop1() + end if + iccount = iccount+1 + num2 = 44-ichar(durq) + call readnum(lineq,iccount,durq,fnum) + num2 = num2*int(fnum+.1) + if (num1.eq.0 .and. .not.ztrans) then +c +c Key change, only one per block allowed +c + if (iskchb) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Only one key change allowed per input block!') + call stop1() + end if + iskchb = .true. + nkeys = nkeys+1 + kchmid(nkeys) = mod(itsofar(ivx),lenbar).ne.0 +c +c Make ibrkch = barnum-1 if at start of bar, so fsyst advances ok at linebreak. +c + ibrkch(nkeys) = ibarcnt+nbars + if (kchmid(nkeys)) ibrkch(nkeys) = ibrkch(nkeys)+1 + newkey(nkeys) = num2+idsig + else +c +c Transposition +c + fulltrans = .true. + if (ibarcnt .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Transposition must be at top of first input block!') + call stop1() + end if + isig1 = num2 + idsig = isig1-newkey(1) +c +c idsig is the difference between sig after transposition, and sig in setup. +c It may alter # of accid's in key changes if there is transposition. +c + end if + else ! durq='i' +c +c 110522/110529 +c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey] +c and repeat i[...] for multiple instruments. Store info here if ibarcnt=0 +c so can pass to topfile (via comInstTrans), which is called before getnote. +c Otherwise, will store info from getnote. Initialize EarlyTransOn and +c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from here; +c LaterInstTrans from g1etnote. Zero both out after use. nInstTrans really +c only needed for instrument-signatures, not transpositions. iTransAmt is +c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for +c each staff. +c +c if (fulltrans) then +c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Cannot yet combine full and instrument transposition!') +c call stop1() +c end if + call GetiTransInfo(.true.,ibarcnt,lineq,iccount, + * ibaroff,nbars,noinst,iv) + end if + else if (charq .eq. '|') then +c +c Optional bar symbol +c + if (mod(itsofar(ivx),lenbar).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar line marker out of place!') + call stop1() + else if (shifton) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar ended with user-defined shift still on!') + call stop1() + end if + else if (charq .eq. '/') then + if (ornrpt) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'WARNING: Block ended with repeated ornament still on!') + ornrpt = .false. + end if + if (stickyS) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'WARNING: Block ended with sticky stemshrink still on!') + stickyS = .false. + end if + if (fbon) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Block ended with forced beam open!') + call stop1() + else if (shifton) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Bar ended with user-defined shift still on!') + call stop1() + else if (gotclef) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'May not enter clef at end of input block!') + call stop1() + end if + barend = .false. +c +c Perform time checks +c + if (mod(itsofar(ivx),lenbar).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Block duration not divisible by lenbar!') + print*,'lenbar is ',lenbar + call stop1() + else if (ivx.gt.1 .and. itsofar(ivx).ne.itsofar(1)) then + print* + print*,'# of bars in voice 1, current voice:', + * itsofar(1)/lenbar,itsofar(ivx)/lenbar + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Block duration not equal to voice 1!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (durq .eq. ' ' .and. iv.eq.nv) then +c +c End of input block +c + loop = .false. + else +c +c Start a new voice +c + if (lenbr0.ne.0 .and. firstline) lenbar = lenbr0 + nbars = 0 + if (durq .eq. ' ') then +c +c New voice is on next staff +c + iv = iv+1 + ivx = iv + else +c +c New voice is on same staff. Set up for it +c + ivx = nv+1 + do 23 iiv = 1 , nv + if (nvmx(iiv) .eq. 2) ivx = ivx+1 +23 continue + if (ivx .gt. nm) then + write(*,'(1x,a21,i3,a23)')'Cannot have more than',nm, + * ' lines of music at once' + call stop1() + end if + nvmx(iv) = 2 + ivmx(iv,2) = ivx + itsofar(ivx) = 0 + nnl(ivx) = 0 + do 24 j = 1 , 200 + rest(ivx,j) = .false. + nacc(ivx,j) = 0 +24 continue +c +c For midi stuff, record that there is a 2nd line of music in this voice +c + if (ismidi) twoline(iv) = .true. + end if + end if + iccount = 128 + else if (charq .eq. 'S') then +c +c New nsyst: for use with partmaker scor2prt, for parts w/ diff # of systs. +c + if (ibarcnt .gt. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"S" can only be in first input block!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + if (index('123456789 ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'A digit must follow "S"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnsyst) + nsyst = nint(fnsyst) +14 continue + if (durq .eq. 'P') then +c +c New npages for parts. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789 ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnsyst) + npages = nint(fnsyst) + go to 14 + else if (durq .eq. 'm') then +c +c Reset musize (musicsize). +c + call g1etchar(lineq,iccount,durq) + if (index('123456789 ',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnsyst) + musize = nint(fnsyst) + wheadpt = whead20*musize + go to 14 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in "S" symbol!') + call stop1() + end if + else if (charq .eq. 'L') then + nflb = nflb+1 + ibarflb(nflb) = ibarcnt+nbars+1 + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Need integer to define forced line break!') + call stop1() + end if + call readnum(lineq,iccount,durq,sysflb) + isysflb(nflb) = nint(sysflb) + if (nflb .gt. 1) then +c +c Check if new number is > prior one +c + if (isysflb(nflb) .le. isysflb(nflb-1)) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'You already forced a line break at a later line!') + call stop1() + end if + end if + if (npages .eq. 0) then + print* + print*,'WARNING! You forced a line break at line ', + * isysflb(nflb),' but npage = 0. Continue?' + read(*,'(a)') charq + if (index('yY',charq) .eq. 0) call stop1() + else if (isysflb(nflb) .gt. nsyst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Forced line break at line num > nsyst!') + call stop1() + else if (index(' PM',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have " ", "P", or "M" here!') + call stop1() + end if + if (durq .eq. 'P') then +c +c Forced page break here, get page number. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Need integer to define forced page break!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + nfpb = nfpb+1 + ipagfpb(nfpb) = nint(fnum) + isysfpb(nfpb) = isysflb(nflb) + if (ipagfpb(nfpb) .gt. npages) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Forced page break at page num > npages!') + call stop1() + else if (nfpb .gt. 1) then + if (ipagfpb(nfpb) .le. (ipagfpb(nfpb-1))) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Forced page break numbers must increase!') + call stop1() + end if + end if + end if + if (index(' M',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in linebreak symbol!') + call stop1() + else if (durq .eq. 'M') then + nmovbrk = nmovbrk+1 + isysmb(nmovbrk) = isysflb(nflb) + call g1etchar(lineq,iccount,durq) +31 if (durq .eq. '+') then +c +c Vertical spacing, read past number. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Integer required here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + go to 31 + else if (durq .eq. 'i') then +c +c Change indentation, +c + call g1etchar(lineq,iccount,durq) + if (index('.123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Decimal number required here!') + call stop1() + end if +c +c fracsys was initialized in block data to all 0.'s +c + call readnum(lineq,iccount,durq,fracsys(nmovbrk)) + go to 31 + else if (durq .eq. 'c') then + call g1etchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'r') then + call g1etchar(lineq,iccount,durq) + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have "+" or "-" after "r" as movement break option!') + call stop1() + end if + call g1etchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'n') then +c +c Change # of voices. Input ninow, iorig(1...ninow). Will use names, +c staves per inst. and clefs corr. to iorig in original list of instruments. +c + nv = 0 + call g1etchar(lineq,iccount,durq) + if (durq .eq. ':') then +c +c Signals a 2-digit number, get next two characters +c + call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,dumq) + if (index('12',durq).eq.0 + * .or.index('0123456789',dumq).eq.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal new number of instruments '//durq//dumq// + * ' at movement break!') + call stop1() + end if + read(lineq(iccount-1:iccount),'(i2)')ninow + else +c +c durq is a single digit number for noinow +c + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal new number of instruments '//durq// + * ' at movement break!') + call stop1() + end if + ninow = ichar(durq)-48 + end if + if (ninow.gt.noinst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'New number of instruments must be <= original!') + call stop1() + end if + do 63 iinow = 1 , ninow + call g1etchar(lineq,iccount,durq) + if (durq .eq. ':') then +c +c Signals a 2-digit number +c + call g1etchar(lineq,iccount,durq) + call g1etchar(lineq,iccount,dumq) + if (index('12',durq).eq.0 + * .or.index('0123456789',dumq).eq.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal 2-digit instrument number '//durq//dumq// + * ' at movement break!') + call stop1() + end if + read(lineq(iccount-1:iccount),'(i2)')iorig + else +c +c durq is a single digit number for iorig +c + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal instrument number '//durq// + * ' at movement break!') + call stop1() + end if + iorig = ichar(durq)-48 + end if + if (iorig .gt. noinst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'New instrument number must be <= original noinst!') + call stop1() + end if + nv = nv+nsperi(iorig) +63 continue + do 61 iiv = 1 , nv +c +c Get clef names +c + call g1etchar(lineq,iccount,durq) + if (.not.(index('tsmanrbf',durq).gt.0 .or. + * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must have t,s,m,a,n,r,b,f or 1-7 as clef symbol here!') + call stop1() + end if +c +c Initialize new voices +c + nvmx(iiv) = 1 + ivmx(iiv,1) = iiv + itsofar(iiv) = 0 + nnl(iiv) = 0 + do 62 j = 1 , 200 + rest(iiv,j) = .false. +62 continue +61 continue +c +c Loop back up, this might not be last option in M +c + call g1etchar(lineq,iccount,durq) + go to 31 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after Movement break symbol!') + call stop1() + end if + if (fracsys(nmovbrk) .lt. 0.001) then +c +c Since fracsys was not explicitly set, set it to prior value. +c + if (nmovbrk .eq. 1) then + fracsys(nmovbrk) = fracindent + else + fracsys(nmovbrk) = fracsys(nmovbrk-1) + end if + end if + end if +c +c Just before exiting if-block for forced line breaks, set counter to use when +c dealing with vertical space calcs +c + nistaff(nflb) = nv-1 + else if (charq .eq. 'F') then + usefig = .false. + else if (charq .eq. 'X') then + call g1etx(lineq,iccount,.true.,shifton,ibarcnt-ibaroff+nbars+1, + * udsp(ibarcnt+nbars+1),wheadpt) + else if (charq .eq. 'I') then +c +c MIDI settings. +c + if (ivx.ne.1 .or. nnl(1).ne.0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'MIDI stuff only allowed at start of block!') + call stop1() + end if + if (nv .gt. 15) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Sorry but MIDI does not work with more than 15 voices!') + call stop1() + end if + ismidi = .true. + call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, + * mtrdenl,.true.) + else if (charq .eq. 'M') then + call setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,ivx, + * nline) + else if (index(',.',charq) .gt. 0) then +c +c Continued rhythmic shortcut +c + idotform = index('. ,',charq) + if (idotform .eq. 1) then +c +c Change duration of prior note +c + itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx)) + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2 + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + end if + idotform = idotform+1 + numnum = 1 + cdot = .true. + go to 1 + else + print*,'ASCII code:',ichar(charq) + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'This character is not allowed here!') + print*,'ASCII code:',ichar(charq) + call stop1() + end if + return + end + subroutine g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, + * xmtrnum0,newkey,npages,nsyst,musize,bottreb) + parameter(nm=24,maxblks=4000) + character*65536 bufq + character*1 chax + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + character*128 lineq + logical lastchar,issegno,isheadr,isvolt,fbon,bottreb, + * newway + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 +c +c Get the first line +c + iccount = 0 + nline = 1 +9 call getbuf(lineq) + if (lineq(1:1) .eq. '%') then + nline = nline+1 + go to 9 + end if + if (lineq(1:3) .eq. '---') then +c +c Have TeX input until next line that starts with '---' +c +3 nline = nline+1 + call getbuf(lineq) + if (ilbuf .gt. nlbuf) go to 1 + go to 2 +1 print*,'You did not terminate type 0 TeX input with "---"' + call stop1() +2 continue + if (lineq(1:3) .ne. '---') go to 3 +c +c Force a new line read on first call to readin +c + iccount = 128 + end if +c +c Here, lineq and nline are first non-TeX lines. +c + nv = nint(readin(lineq,iccount,nline)) + if (nv .gt. nm) then + write(*,'(1x,a46,i3)') + * 'In setup data, number of voices cannot exceed',nm + call stop1() + end if + noinst = nint(readin(lineq,iccount,nline)) + if (noinst .gt. nv) then + write(*,'(a)') + * 'In setup data, cannot have more instruments than staves' + call stop1() + end if + newway = noinst.le.0 + if (newway) noinst = -noinst + do 10 iinst = 1 , noinst +c +c Seve # of staves per inst in case later drop some inst's. +c + if (newway) then + nsperi(iinst) = nint(readin(lineq,iccount,nline)) + else if (iinst .gt. 1 ) then + nsperi(iinst) = 1 + else + nsperi(iinst) = nv-noinst+1 + end if +10 continue + mtrnuml = nint(readin(lineq,iccount,nline)) + mtrdenl = nint(readin(lineq,iccount,nline)) +cc +cc Kluge!!! +cc +c if (mtrdenl .eq. 1) then +c mtrdenl = 2 +c mtrnuml = mtrnuml*2 +c end if + mtrnmp = nint(readin(lineq,iccount,nline)) + mtrdnp = nint(readin(lineq,iccount,nline)) + if (mtrnmp.eq.0 .and. mtrdnp .ge. 8) then + write(*,'(a)')'In setup data, with mtrnmp=0, mtrdnp must be <8' + call stop1() + end if + xmtrnum0 = readin(lineq,iccount,nline) + newkey = nint(readin(lineq,iccount,nline)) + npages = nint(readin(lineq,iccount,nline)) + nsyst = nint(readin(lineq,iccount,nline)) + musize = nint(readin(lineq,iccount,nline)) + fracindent = readin(lineq,iccount,nline) + if (fracindent .ge. 1.) then + write(*,'(a)')'In setup data, fracindent must be <1' + call stop1() + end if + if (npages .gt. nsyst) then + print*,'Error in input file: npages > nsyst' + call stop1() + else if((musize-16)*(musize-20)*(musize-24)*(musize-29).ne.0) then + call printl('Musicsize must be 16, 20, 24, or 29') + call stop1() + end if +c +c Next noinst non-comment lines are names of instruments. +c + do 4 i = 1 , abs(noinst) +5 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 5 +4 continue +c +c Mext non-comment line has nv clef names +c +6 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 6 + do 7 iv = 1 , nv +c if (index('brnamstf0123456',lineq(iv:iv)) .eq. 0) then + if (index('brnamstf01234567',lineq(iv:iv)) .eq. 0) then + call errmsg(lineq,iv,0, + * 'There should be a clef symbol here!') + call stop1() + end if +7 continue + if (lineq(nv+1:nv+1) .ne. ' ') then + call errmsg(lineq,nv+1,0, + * 'There should be a blank here!') + call stop1() + end if +c +c Set flag if voice 1 is treble, since it affects vertical spacing +c + bottreb = lineq(1:1).eq.'t' +c +c Mext non-comment line has path name +c +8 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 8 + lpath = index(lineq,' ')-1 + if (index('/:'//chax(92),lineq(lpath:lpath)) .eq. 0) then + call errmsg(lineq,lpath,0, + * 'Last character of pathname is not "/",":", or "' + * //chax(92)//'"!') + call stop1() + end if + return + end + subroutine g1etx(lineq,iccount,notxtup,shifton,ibar,udsp,wheadpt) +c +c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol. +c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols. +c + logical notxtup,shifton,number,btest + character*128 lineq + character*1 charq,dumq + number = .false. + nPBSc = 0 +1 call g1etchar(lineq,iccount,charq) + if (index('PBS:',charq) .gt. 0) then +c +c Continue checking here even if "P". +c + ipbsc = index('PBS:',charq) + if (btest(nPBSc,ipbsc)) then + call errmsg(lineq,iccount,ibar,'Only one allowed per symbol!') + call stop1() +c else if (.not.notxtup .and. ipbsc.gt.2) then +c call errmsg(lineq,iccount,ibar,'Not allowed in xtuplet!') +c call stop1() + end if + nPBSc = ibset(nPBSc,ipbsc) + go to 1 + else if (index('+-.0123456789',charq) .gt. 0) then + number = .true. + if (index('+-',charq) .gt. 0) then + call g1etchar(lineq,iccount,dumq) + if (index('.0123456789',dumq) .eq. 0) then + call errmsg(lineq,iccount,ibar,'Expected a number here!') + call stop1() + end if + end if + call readnum(lineq,iccount,dumq,fnum) + if (charq.eq.'-') fnum = -fnum + if (dumq .ne. 'p') then + iccount = iccount-1 + fnum = fnum*wheadpt + end if + go to 1 + else if (charq .ne. ' ') then + call errmsg(lineq,iccount,ibar,'Not allowed in "X" symbol!') + call stop1() + end if +c +c Done with parsing. Other checks +c + if (iand(6,nPBSc).eq.6 .or. iand(24,nPBSc).eq.24) then + call errmsg(lineq,iccount-1,ibar, + * 'Cannot have both "P" and "B" or "S" and ":"!') + call stop1() + end if + if (btest(nPBSc,4)) then + if (number) then + if (shifton) then + call errmsg(lineq,iccount-1,ibar, + * 'Started a group shift without stopping prior one!') + call stop1() + else + shifton = .true. + end if + else + if (.not. shifton) then + call errmsg(lineq,iccount-1,ibar, + * 'Ended a group shift without starting one!') + call stop1() + else + shifton = .false. + end if + end if + end if +c +c P off, S off, c off => normal user-defined space. Add to udsp (later fsyst) +c + if (iand(nPBSc,26).eq.0) udsp = udsp+fnum + if (.not.number .and. .not.btest(nPBSc,4)) then + call errmsg(lineq,iccount-1,ibar, + * 'Must have either a number or a colon in "X" symbol!') + call stop1() + end if + return + end +c integer*4 function mytime() +c CHARACTER(10) tq +c CALL DATE_AND_TIME(TIME=tq) +c read(tq,'(2i2,f6.3)')ih,im,ts +c mytime = 1000*(ts+60*(im+60*ih)) +c return +c end + subroutine getbuf(lineq) + parameter (maxblks=4000) + character*(*) lineq + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + lineq = bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) + ipbuf = ipbuf+lbuf(ilbuf) + ilbuf = ilbuf+1 + return + end + subroutine getchar(lineq,iccount,charq) + parameter (nm=24) +c +c Gets the next character out of lineq*128. If pointer iccount=128 on entry, +c then reads in a new line. Resets iccount. Ends program if no more input. +c + common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, + * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, + * rptprev,equalize,rptfq1,rptfq2 + logical lastchar,rptnd1,sluron,fbon,rptprev,ornrpt + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac,equalize,stickyS + character*1 charq,rptfq1,rptfq2 + character*128 lineq,lnholdq + if (iccount .eq. 128) then + call read10(lineq,lastchar) + if (lastchar) return + if (.not. endmac) then + iccount = 0 + else + endmac = .false. + iccount = icchold + lineq = lnholdq + end if + if (mrecord) then + call mrec1(lineq,iccount,ndxm) + end if + end if + iccount = iccount+1 + charq = lineq(iccount:iccount) + return +999 continue + lastchar = .true. + return + end + subroutine getdyn(ivx,ip,irest,iornq,lineq,iccount) + parameter (nm=24) + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical fontslur,upslur,WrotePsslurDefaults + character*1 durq,chax + character*4 dynsymq + character*128 lineq +c +c Get info for dynamic mark. Enter after getting "D", iccount sits on "D" +c Bits in idyndat are as follows +c 00-03 ivx +c 04-11 ip +c 12-15 code for type of mark +c 0 => arbitrary text +c 1-12 => pppp,ppp,pp,p,mp,mf,f,fp,sfz,ff,fff,ffff +c If (.not. fontslur) +c 13 => hairpin start, 14,15 => <,> (ending) +c else +c 13 < start, 14 > start, 15 ending +c end if +c 16 flag for vertical offset +c 17-23 vertical offset + 64 , \internote +c 31 Hairpin start (0), stop (1) +c +c idynda2 +c +c 00 flag for horizontal offset +c 01-09 (horizontal offset)/10 + 25.6 notehead widths +c 10 5th bit for ivx (5/15/10) +c + irest = ibset(irest,26) + ndyn = ndyn+1 + idyn = ivx + idynda2(ndyn) = 0 + if (ivx .ge. 16) call setbits(idynda2(ndyn),1,10,1) + call setbits(idyn,8,4,ip) + if (lineq(iccount+1:iccount+1) .eq. '"') then +c +c text-dynamic +c + ntxtdyn = ntxtdyn+1 + iend = iccount+index(lineq(iccount+2:128),'"')+2 + txtdynq(ntxtdyn) = lineq(iccount+2:iend-2) +c +cc Store ivx, ip in bits 0-11 +c Store ivx, ip in bits 0-12 +c +c ivxiptxt(ntxtdyn) = idyn + ivxiptxt(ntxtdyn) = ivx+32*ip + ipm = index('- +',lineq(iend:iend)) + idno = 0 + else +c +c Word-group or hairpin +c + do 1 iend = iccount+2 , 128 + ipm = index('- +',lineq(iend:iend)) +c +c Exit the loop at first blank, "+", or "-" +c + if (ipm .gt. 0) go to 2 +1 continue +2 continue + read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')') + * dynsymq + idno = (index( + * 'ppppppp pp p mp mf f fp sfz ff fff ffff < > ', + * dynsymq)+3)/4 +c +c Save for later down +c + idno1 = idno + end if +c +c Set flag to check level later if in beam +c + iornq = ibset(iornq,23) + if (idno.ge.14) then +c +c Hairpin here. Check if opposite type from one that's already on +c + if (idno.eq.14.and.btest(listdecresc,ivx) .or. + * idno.eq.15.and.btest(listcresc,ivx)) then + call printl(' ') + call printl('Started one kind of hairpin while other is on') + call stop1() + end if +c +c Start or stop? +c + if (btest(listcresc,ivx) .or. btest(listdecresc,ivx)) then +c +c Cresc/decresc is on, this is an ending. If fontslur, leave idno as is. +c + if (.not.fontslur) idno = 15 + else if (fontslur) then +c +c Start of font slur +c + idno = 13 + else +c +c Start of postscript slur +c + idno = idno-1 + end if + end if +c +c Now that we used list[de]cresc, update +c + if (idno .ge.13) then + if (idno.eq.15 .or. (fontslur.and.idno.eq.14)) then +c +c Something's ending +c + if (btest(listcresc,ivx)) then +c +c It's a cresc! +c + listcresc = ibclr(listcresc,ivx) + else + listdecresc = ibclr(listdecresc,ivx) + end if + else +c +c Something's starting +c + if (idno1 .eq. 14) then +c +c It's a cresc! +c + listcresc = ibset(listcresc,ivx) + else + listdecresc = ibset(listdecresc,ivx) + end if + end if + end if + call setbits(idyn,4,12,idno) + iccount = iend + if (ipm .ne. 2) then +c +c There is a vertical shift +c + idyn = ibset(idyn,16) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + idno = nint(fnum) + call setbits(idyn,7,17,(ipm-2)*idno+64) + ipm = index('- +',durq) + if (ipm .ne. 2) then +c +c There is a horizontal shift +c +c idynda2(ndyn) = ibset(idyn,23) + idynda2(ndyn) = ibset(idynda2(ndyn),0) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + idno = nint(10*fnum) + call setbits(idynda2(ndyn),9,1,(ipm-2)*idno+256) + end if +c +c iccount should be on the blank at the end of the entire symbol +c + end if + idyndat(ndyn) = idyn + return + end + subroutine getfig(itoff,charq,lineq,iccount,isfig,itfig, + * itsofar,nodur,figq,ivupfig,nfigs) + logical isfig + character*1 charq + character*10 figq + character*128 lineq +c +c As of 11/26/08, trapped extra figures in getnote, so no need here. +c +c if (ivx .gt. 2) then +cc +cc Read past the figure +cc +c6 call getchar(lineq,iccount,charq) +c if (charq .ne. ' ') go to 6 +c return +c end if + nfigs = nfigs+1 + ivupfig = 0 + itoff = 0 + if (charq .eq. 'x') then +c +c Floating figure. +c + call getchar(lineq,iccount,charq) + read(charq,'(i1)')noff + call getchar(lineq,iccount,charq) + read(charq,'(i1)')loff + itoff = noff*ifnodur(loff,'x') + call getchar(lineq,iccount,charq) + else +c +c Figure on a note +c + isfig = .true. + end if + itfig = itsofar+itoff-nodur + lfig = 1 + figq = charq +5 call getchar(lineq,iccount,charq) +c if (charq .ne. ' ') then + if (index(' +',charq) .eq. 0) then + figq = figq(1:lfig)//charq + lfig = lfig+1 + go to 5 + else if (charq .eq. '+') then +c +c Get vertical offset for figure. Next character after number has to be blank. +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + ivupfig = nint(fnum) + end if + return + end + subroutine getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, + * lastlev,iv,nv) + parameter (nm=24) + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg + character*1 charq,durq + character*20 voltxtq + character*128 lineq,litq + integer*4 islur(nm,200),iornq(nm,0:200),ipl(nm,200),nnl(nm), + * ndlev(nm,2) + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans +c +c Grace, comes *before* main note: +c UNLESS there's an 'A' or 'W' after the 'G' +c ngrace = # of grace note groups so far in block +c ivg(ngrace), ipg(ngrace) +c nng(ngrace) = # of notes in this group: default = 1 +c ngstrt(ngrace) = starting position in nolevg of levels for this grace +c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)' +c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l' +c slurg(ngrace) = logical for slur; default F, input 's' +c slashg(ngrace) = T if slash; default is F, input 'x' +c These data MUST precede note name of first note +c nolevg, naccg: lists of levels and accid's, indexed as described above. +c + ngrace = ngrace+1 + ivg(ngrace) = ivx + ipg(ngrace) = nnl(ivx)+1 + if (ngrace .eq. 1) then + ngstrt(ngrace) = 1 + else + ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1) + end if + islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4) + nng(ngrace) = 1 + multg(ngrace) = 1 + upg(ngrace) = .true. + slurg(ngrace) = .false. + slashg(ngrace) = .false. +18 call getchar(lineq,iccount,charq) + if (index('WA',charq) .gt. 0) then +c +c Grace is on note that was already done, so shift flags forward one note. +c This puts flag on actual note with grace; later for W will go ahead one more. +c + ipg(ngrace) = nnl(ivx) + islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4) + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4) + if (slurg(ngrace)) + * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24) + if (charq .eq. 'A') then +c +c close After, clear way-after bit, to ensure priority of most recent A/W +c + ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29) + else +c +c Way after; later assign to following note, and position like normal grace. +c + ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31) + end if + else if (charq .eq. 'm') then + call getchar(lineq,iccount,charq) + multg(ngrace) = ichar(charq)-48 + else if (index('123456789',charq) .gt. 0) then + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + nng(ngrace) = nint(fnum) + else if (charq .eq. 'l') then + upg(ngrace) = .false. + else if (charq .eq. 's') then + slurg(ngrace) = .true. + if (nnl(ivx) .gt. 0) then +c +c If A- or W-grace, set signal to start slur on main note. +c + if(btest(ipl(ivx,nnl(ivx)),31) .or. + * btest(ipl(ivx,nnl(ivx)),29)) + * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24) + end if + else if (charq .eq. 'x') then + slashg(ngrace) = .true. + else if (charq .eq. 'u') then + else if (charq .eq. 'X') then +c +c Space before main note of grace. Number will come next. +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,graspace(ngrace)) + iccount = iccount-1 + end if + if (index('abcdefg',charq) .eq. 0) go to 18 +c +c At this point, charq is first note name in grace +c + do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1 + naccg(ing) = 0 + ioct = 0 + if (ing .gt. ngstrt(ngrace)) then +55 call getchar(lineq,iccount,charq) + if (charq .eq. ' ') go to 55 + endif + iclastlev = 0 +9 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then + if (durq.eq.'+') then + lastlev = lastlev+7 + iclastlev = iclastlev+7 + else if (durq.eq.'-') then + lastlev = lastlev-7 + iclastlev = iclastlev-7 + else if (index('fsn',durq) .gt. 0) then + if (naccg(ing) .eq. 0) then + naccg(ing) = index('fsn',durq) + else +c +c Double accidental +c + naccg(ing) = ibset(naccg(ing),2) + end if + else + ioct = ichar(durq)-48 + end if + go to 9 + end if + if (ioct .gt. 0) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + else + if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + lastlev = ndlev(iv,kv)+iclastlev + end if + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + end if + nolevg(ing) = lastlev +19 continue +c +c Grace could come before first note of block, so reset end level. +c + if (nnl(ivx).eq.0) then + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + ndlev(iv,kv) = lastlev + end if + return + end + subroutine GetiTransInfo(From1,ibarcnt,lineq,iccount, + * ibaroff,nbars,noinst,iv) +cccccccccccccccccccccccc +cc +cc GetiTransInfo.for +cc +cccccccccccccccccccccccc +c +c Called from both g1etnote and getnote, after first 'i' in Ki[...] +c On entry, iccount points to last char retrieved, which is 'i' +c +c From1: locgical, true if called from g1etnote +c ibarcnt: tells whether to set EarlyTransOn to true. +c EarlyTransOn set false in blkdata, true here, back to false in topfile. +c +c 110522/110529 +c Instrument-wise transposition Ki[iInstTrans][+/-][iTransAmt][+/-][iTransKey] +c and repeat i[...] for multiple instruments. Store info in g1etnot if ibarcnt=0 +c so can pass to topfile (via comInstTrans), which is called before getnote. +c Otherwise, will store info from getnote. Initialize EarlyTransOn and +c LaterInstTrans to .false. in blockdata. Set EarlyTransOn from g1etnote; +c LaterInstTrans from getnote. Zero both out after use. nInstTrans really +c only needed for instrument-signatures, not transpositions. iTransAmt is +c ALWAYS active per instrument. Set up instno(iv) so can fetch iTransAmt for +c each staff. +c +c iTransAmt stored as fn of instrument #, not like iTransKey which is +c fn. of nm, just a counter, where corr. inst num is iInstTrans(nm). This +c simplifies use of iTransAmt for all calls to ifnolev. +c + parameter (nm=24) + logical From1 + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans,store + character*128 lineq + character*1 durq + durq = 'x' ! Can't initialize in declaration stmt, only works once. + if(.not.EarlyTransOn) EarlyTransOn = From1 .and. ibarcnt.eq.0 + store = (EarlyTransOn.and.ibarcnt.eq.0) .or. + * (ibarcnt.gt.0.and..not.From1) + LaterInstTrans = .not.From1 .and. ibarcnt.gt.0 + if (store) nInstTrans = 0 +1 continue + if (durq .eq. ' ') return + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be an instrument number here!') + call stop1() + end if + if (store) nInstTrans = nInstTrans+1 + call readnum(lineq,iccount,durq,fnum) + instn = nint(fnum) + if (instn.gt.noinst) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Instrument number out of range!') + call stop1() + end if + if (store) iInstTrans(nInstTrans) = instn +c +c durq is +/- following inst # (for iTransAmt), iccount is on it. +c + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st character after instrument number must be "+,-"!') + call stop1() + end if + itramt = 44-ichar(durq) ! +1/-1 for itramt + call g1etchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a transposition amount here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (store) iTransAmt(instn) = nint(fnum)*itramt +c +c durq is +/- following iTransAmt (for iTransKey), iccount is on it. +c + if (index('+-',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '1st character after transposition amount must be "+,-"!') + call stop1() + end if + ikey = 44-ichar(durq) ! +1/-1 + call g1etchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be a key indicator here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + if (store) iTransKey(nInstTrans) = nint(fnum)*ikey +c +c durq is now 1st character after iTransKey, should be either 'i' or ' ' +c + if (durq.ne.'i'.and.durq.ne.' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'There must be blank or "i" here!') + call stop1() + end if + go to 1 + end + subroutine getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, + * mtrdenl,first) +c +c Use this from both pmxa and pmxb to input and check midi data. "first" tells +c whether pmxa or pmxb. If .not.first, then tempo and pause commands cause +c things to be written immediately into the midi storage buffers. +c + parameter (nm=24,mv=24576) + common /comevent/ miditime,lasttime + logical mmacrec,gottempo + common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, + * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), + * mmacrec,gottempo +c +c immac(i) is the index of i-th macro, i=1,nmac. Also make a list containing +c nmidsec section starts and stops based on PLAYING macros (not recording). +c + integer*2 mmidi,midinum(26) + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + character*1 durq + character*2 instq + character*128 lineq + logical first + common /comdiag/ n69(0:nm),n34(0:nm) +c +c Instrument codes +c + data midinum + * / 1, 5, 7, 13,20,25,33,41,42,43,44,57,58,59,61,65,66,67, +c XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbXtuXfrXsoXalXteX +c + * 68,69,71,72,74,75, 8,55 / +c bsXobXbaXclXflXreXctXvo +c +1 call getchar(lineq,iccount,durq) + if (durq .eq. 't') then +c +c Tempo in beats ber minute +c + call getchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected an integer here for the pause!') + call stop1() +c else if (mmacrec) then +c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Cannot change MIDI tempo while recording a MidiMacro!') +c call stop1() + end if + call readnum(lineq,iccount,durq,qpm) + iccount = iccount-1 + if (.not.first) then + call midievent('t',nint(qpm),0) + gottempo = .true. + end if + go to 1 + else if (durq .eq. 'p') then +c +c Insert a pause. pausemid = pause in 1/4's +c + call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a number here for the pause!') + call stop1() + end if + call readnum(lineq,iccount,durq,pausemid) + iccount = iccount-1 + if (.not.first) then +c +c Compute a meter for the pause. This is only to keep MidiNotate on track. +c Round pause to nearest 16th. Let denominator always be 16. +c + numb16 = nint(pausemid*4) + call midievent('m',numb16,16) +c +c Put in pausemid beats of rest +c + do 3 icm = 0 , numchan-1 + call addmidi(icm,0,0,0,4.*numb16,.true.,.false.) +3 continue + miditime = miditime+nint(240*pausemid) +c +c Restore meter +c + call midievent('m',mtrdenl*lenbar/64,mtrdenl) + end if + go to 1 + else if (durq .eq. 'i') then +c +c Instrument numbers or letters. Expect nv of them. +c + do 2 ivx = 1 , nv + call getchar(lineq,iccount,durq) + if (ichar(durq) .gt. 96) then +c +c It's a lowercase letter. Get another, find corr. instrument #. +c + instq(1:1) = durq + call getchar(lineq,iccount,durq) + instq = instq(1:1)//durq + iname = index('XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbX'// + * 'tuXfrXsoXalXteXbsXobXbaXclXflXreXctXvo',instq)/3 + if (iname .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Unrecognized 2-letter midi instrument name!') + call stop1() + end if + midinst(ivx) = midinum(iname)-1 + else +c +c Expect a number, followed by ":" if that is followed by another number. +c I.e., if after call to readnum, durq is not ":", it must be either blank +c or next instrument letter. +c + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a midi instrument number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + midinst(ivx) = nint(fnum)-1 + if (midinst(ivx).lt.0 .or. midinst(ivx).gt.255) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Midi instrument number must be in range 1-128!') + call stop1() + end if + if (durq .ne. ':') iccount = iccount-1 + end if +2 continue + go to 1 + else if (durq .eq. 'v') then +c +c Get volumes for each instrument. Expect nv of them. +c Follow same pattern as for insttrument numbers above. +c + do 7 ivx = 1 , nv + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a midi velocity number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + midivel(ivx) = nint(fnum)-1 + if (midivel(ivx).lt.0 .or. midivel(ivx).gt.127) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Midi velocity must be in range 1-128!') + call stop1() + end if + if (durq .ne. ':') iccount = iccount-1 +7 continue + go to 1 + else if (durq .eq. 'b') then +c +c Get balance for each instrument. Expect nv of them. +c Follow same pattern as for instrument numbers above. +c + do 8 ivx = 1 , nv + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a balance number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + midibal(ivx) = nint(fnum)-1 + if (midibal(ivx).lt.0 .or. midibal(ivx).gt.127) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Midi balance must be in range 1-128!') + call stop1() + end if + if (durq .ne. ':') iccount = iccount-1 +8 continue + go to 1 + else if (durq .eq. 'T') then +c +c Get transposition for each instrument. Expect nv of them. +c Follow similar pattern as above, but separator is +|-. +c + do 9 ivx = 1 , nv + call getchar(lineq,iccount,durq) + ipm = index('-+',durq) + if (ipm .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected "+" or "-" for midi transposition here!') + call stop1() + end if + ipm = 2*ipm-3 + call getchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected a number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + miditran(ivx) = ipm*nint(fnum) +c if (mod(miditran(ivx),12).ne. 0) then +c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, +c * 'Midi transposition limited to multiples of 12!') +c call stop1() +c end if + iccount = iccount-1 +9 continue + go to 1 + else if (durq .eq. 'g') then + call getchar(lineq,iccount,durq) + if (index('0123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected an integer here for the midi gap!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + mgap = nint(fnum) + iccount = iccount-1 + go to 1 + else if (durq .eq. 'M') then +c +c MidiMacros +c + call getchar(lineq,iccount,durq) + if (durq .eq. 'R') then +c +c Start recording +c + if (mmacrec) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You tried to record a MidiMacro while already recording!') + call stop1() + end if + mmacrec = .true. + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected MidiMacro ID number here!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + if (.not.first) then + immac = nint(fnum) + if (immac .gt. 20) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'MidiMacro ID cannot exceed 20!') + call stop1() + end if +c +c Save the start time +c + mmactime(immac) = miditime + do 4 icm = 0 , numchan + if (icm .lt. numchan) then + if (restpend(icm)) then +c +c Adjust if there's a rest at end of prior section. Insert dummy turnoff. +c (This causes two turn-offs in a row, which testmidi sees as an error). +c +c Before: section1 ------rest------- section2(to be recorded) +c After: section1 rest1 now rest2 section2(recorded) +c + call addmidi(icm,30,0,0,trest(icm),.false.,.true.) + trest(icm) = 0 + restpend(icm) = .false. + end if + else + if (miditime .gt. lasttime) then +c +c Insert a dummy turnoff in conductor track +c + call addmidi(icm,30,0,0,(miditime-lasttime)/15., + * .false.,.true.) + lasttime = miditime + end if + end if + mmacstrt(icm,immac) = imidi(icm)+1 +4 continue + end if + go to 1 + else if (index('123456789P',durq) .eq. 0) then +c +c End recording; close the open macro. Get immac from common. +c + if (.not.mmacrec) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'You tried to end a MidiMacro before starting one!') + call stop1() + end if + mmacrec = .false. + iccount = iccount-1 + if (.not.first) then +c +c Save the macro duration +c + mmactime(immac) = miditime-mmactime(immac) + do 5 icm = 0 , numchan + if (icm .lt. numchan) then + if (restpend(icm)) then + call addmidi(icm,30,0,0,trest(icm),.false.,.true.) + trest(icm) = 0 + restpend(icm) = .false. + end if + else + if (miditime .gt. lasttime) then +c +c Insert a dummy turnoff in conductor track if needed. +c + call addmidi(icm,30,0,0,(miditime-lasttime)/15., + * .false.,.true.) + lasttime = miditime + end if + end if + mmacend(icm,immac) = imidi(icm) +5 continue + end if + if (durq .ne. ' ')go to 1 + else if (durq .eq. 'P') then +c +c Play Back a Macro +c + call getchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Expected MidiMacro ID number here!') + call stop1() + end if + if (mmacrec) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'You tried to play a MidiMacro before ending recording!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + if (.not.first) then + immac = nint(fnum) + if (mmactime(immac) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Cannot play a MIDI macro before recording it!') + call stop1() + end if + do 6 icm = 0 , numchan + if (icm .lt. numchan) then + if (restpend(icm)) then + call addmidi(icm,30,0,0,trest(icm),.false.,.true.) + trest(icm) = 0. + restpend(icm) = .false. + end if + else + if (miditime .gt. lasttime) then +c +c Insert a dummy turnoff in conductor track +c + call addmidi(icm,30,0,0,(miditime-lasttime)/15., + * .false.,.true.) + end if + end if + msecend(icm,nmidsec) = imidi(icm) + msecstrt(icm,nmidsec+1) = mmacstrt(icm,immac) + msecend(icm,nmidsec+1) = mmacend(icm,immac) + msecstrt(icm,nmidsec+2) = imidi(icm)+1 +6 continue + nmidsec = nmidsec+2 +c +c Update running time +c + miditime = miditime+mmactime(immac) + lasttime = miditime + end if + go to 1 + else + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in MidiMacro sub-command!') + call stop1() + end if + else if (durq .eq. 'd') then + debugmidi = .true. + go to 1 + else if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character in MIDI input data!') + call stop1() + end if + if (.not.gottempo .and. .not.first) then +c +c If no tempo is set on first call on the pmxb pass, then set it +c + call midievent('t',96,0) + gottempo = .true. + end if + return + end + subroutine getnote(loop) + parameter (nm=24,mv=24576) + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*10 figq + character*1 ulq,sepsymq,sq,rptfq1,rptfq2,clefq,chax + logical beamon,firstgulp,figbass,figchk,isfig + character*60 cheadq + character*120 instrq,titleq,compoq + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,autofbon + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /cominbot/ inbothd + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd, + * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage, + * OptLineBreakTies,HeaderSpecial + common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, + * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, + * rptprev,equalize,rptfq1,rptfq2 + common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,fbon,ornrpt,shifton,setis,notcrd,isbjmp, + * was2,nobar1,quoted,isbj2,stickyS, + * OptLineBreakTies,HeaderSpecial + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + character*128 litq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /combc/ bcspec + common /comas3/ ask(2500),iask,topmods +c +c nvmx is either 1 or 2. ivmx(iv,1)=iv, ; ivmx(iv,2)>nv if defined +c ivx is current ivmx, and is the index for all notes, acc's etc. +c + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /comtrans/ cheadq + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + common /comclefq/ clefq(nm) + common /comtol/ tol + common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), + * ArpShift(20) + character*128 txtdynq + logical mrecord,mplay,endmac,lowdot,rename,bar1syst,upslur, + * fontslur,WrotePsslurDefaults + character*128 lineq,lnholdq + character*80 headrq, lowerq + character*79 inameq + character*59 hdlndq + character*20 voltxtq + character*1 charq,dotq,durq,ulfbq,dumq + logical loop,lastchar,lower,rptnd1,rptprev,bcspec,moved, + * topmods,headlog,btest,sluron,cdot,equalize + character*24 tempq + logical novshrinktop,cstuplet + common /comnvst/ novshrinktop,cstuplet + logical kbdrests + common /comkbdrests/ levbotr(8),levtopr(8),kbdrests + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + + common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idumm1,isig1, + * mbrestsav,kchmid(18),logdumm1,logdumm2,barend,noinst,logdumm3 + logical barend,iskchb,kchmid,logdumm1,logdumm2,logdumm3 + common /combibarcnt/ ibarcnt + cdot = .false. +1 call getchar(lineq,iccount,charq) + if (lastchar) return + if (charq .eq. ' ') go to 1 + if (charq .eq. '%') then +c +c Check for a bar number format: +c + if (iccount.eq.1 .and. lineq(2:2).eq.' ' .and. + * index('bB1234567890',lineq(3:3)).gt.0) then + if (islast) write(11,'(a)')lineq(1:lenstr(lineq,128)) + end if + iccount = 128 + go to 1 + end if +c +c Closing repeat iff charq='/' and the prev. char was 'R' with 'd' or 'r' +c + if (rptprev) then + rptnd1 = charq .eq. '/' + rptprev = .false. + end if +c +c Repeat at end of a piece +c + if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or. + * charq.eq.'r') then + if (cdot) go to 28 +c +c This is a note/rest. +c + idotform = 0 + numnum = 0 +c +c If start of line of music, set pitch from previous +c + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + if (nnl(ivx).eq.0) lastlev = ndlev(iv,kv) +c +c notcrd is used to tell if orn. goes on main note or chord note +c +c notcrd = .true. !Move dow. Was not observed if dotted shortcut. +c +c Increase note count, then loop 'til blank. Label 28 is for dotted shortcuts. +c +28 continue +c +c Moved this from just above, 2 Feb 02 +c + notcrd = .true. + nnl(ivx) = nnl(ivx)+1 + if (ornrpt) then +c +c Replicate ornament bits, also bit 23 for beam handling if chord. +c + iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),iornq(ivx,0)) + if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then +c +c This is a trill (bit 7 or 15) so must dup the parameters +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = nnl(ivx) + xnsktr(ntrill) = xnsktr(ntrill-1) + end if + end if + if (stickyS) then +c +c Grab stemlength shortening parameters from prior note +c + mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27) + call setbits (mult(ivx,nnl(ivx)),3,28, + * igetbits(mult(ivx,nnl(ivx)-1),3,28)) + end if + if (autofbon .and. tautofb.gt.tol .and. .not.fbon) then +c +c Doing auto forced beams, and period has been set, so check if this note +c starts a period. +c +c if (mod(1.*itsofar(ivx),tautofb) .lt. tol) then + if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then +c +c Start a forced beam here +c + nfb(ivx) = nfb(ivx)+1 + fbon = .true. + ulfbq(ivx,nfb(ivx)) = 'x' + t1fb(ivx,nfb(ivx)) = itsofar(ivx) + end if + end if + if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30) + dotq = 'x' + if (charq.eq.'r') + * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0) + if (btest(irest(ivx,nnl(ivx)),0)) then +c +c Rest stuff. First check if previous note was full-bar-pause +c + if (lineq(iccount+1:iccount+1) .eq.' ' + * .and. nnl(ivx).gt.1) then + if (btest(islur(ivx,nnl(ivx)-1),19)) + * islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19) + end if +c +c Set default rest level at 0 unless 2 voices/staff in which case it's -4 or 2 +c for voice a or b. Set a-types at 0 as encountered and adjust later +c after '//'. (Override heights will be set to 100+offset) +c + if (ivx .le. nv) then + nolev(ivx,nnl(ivx)) = 0 + else + nolev(ivx,nnl(ivx)) = 2 + end if + end if +2 call getchar(lineq,iccount,durq) + ic = ichar(durq) + if (ic.le.57 .and. ic.ge.48) then +c +c Digit +c + if (numnum .eq. 0) then + nnodur = ic-48 + numnum = 1 + go to 2 + else if (numnum .eq. 1) then + ioct = ic-48 + numnum = 2 + go to 2 + else + print*,'>2 digits in note sym., ivx,nn:',ivx,nnl(ivx) + call stop1() + end if + else if (durq .eq. 'd') then + dotq = durq + if (lineq(iccount+1:iccount+1) .eq. 'd') then +c +c Double dot. +c + iccount = iccount+1 + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),3) + end if + if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then +c +c move a dot, unless next char is not part of a number +c + if (index('0123456789.',lineq(iccount+2:iccount+2)) .eq. 0) + * go to 2 + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),19) + call getchar(lineq,iccount,durq) + ndotmv(ivx) = ndotmv(ivx)+1 + iccount=iccount+1 + call readnum(lineq,iccount,dumq,updot(ivx,ndotmv(ivx))) + if (durq .eq. '-') + * updot(ivx,ndotmv(ivx)) = -updot(ivx,ndotmv(ivx)) + if (index('+-',dumq) .gt. 0) then +c +c Vertical shift also +c + iccount=iccount+1 + call readnum(lineq,iccount,durq,rtdot(ivx,ndotmv(ivx))) + if (dumq .eq. '-') + * rtdot(ivx,ndotmv(ivx)) = -rtdot(ivx,ndotmv(ivx)) + else + rtdot(ivx,ndotmv(ivx)) = 0. + end if + iccount = iccount-1 + end if + go to 2 + else if (durq .eq. 'p') then +c +c Full-bar rest as pause +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19) + go to 2 + else if (durq .eq. 'b') then +c +c Blank rest +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29) + go to 2 + else if (index('fsn',durq) .gt. 0) then +c +c Accidental +c + if (nacc(ivx,nnl(ivx)) .eq. 0) then +c +c No accidental has been set yet +c + nacc(ivx,nnl(ivx)) = index('fsn',durq) + else +c +c Repeated accid, so must be double +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2) + end if + go to 2 + else if (durq .eq. 'i') then +c +c Set flag for MIDI-only accidental. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17) + go to 2 + else if (durq .eq. 'c') then +c +c Set flags for cautionary accidental +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31) + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) + go to 2 + else if (index('+-<>',durq) .gt. 0) then + ipm = index('- +',durq)-2 + if (.not.btest(irest(ivx,nnl(ivx)),0)) then +c +c A note, not a rest. +c + call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved) + if (moved) go to 2 +c +c Octave jump with a note +c + if (numnum .lt. 2) then + lastlev = lastlev+ipm*7 + else + ioct = ioct+ipm*1 + end if + go to 2 + else +c +c Override default height of a rest +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (lineq(iccount-1:iccount-1) .eq. '.') then +c +c Kluge in case there is a shortcut ".". It will have been sucked up by +c readnum. (Same doesn't hold for ",") +c + iccount = iccount-2 + go to 2 + end if + nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum) +c +c There may be more characters for this rest +c + iccount = iccount-1 + go to 2 + end if + else if (durq .eq. 'x') then +c +c Xtuplet. Count number of doubled notes (for unequal xtups) +c + if (btest(nacc(ivx,nnl(ivx)),18)) then + ndoub = 1 + else + ndoub = 0 + end if +c +c Will set all durations to 0 except last one. Set flag on this note. +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),28) +c +c Next input will be digit +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + ntup = nint(fnum) + if (index('DF',durq) .gt. 0) then +c +c Double xtup note to make an un= xtup. Here xtup number already set but may also +c have this command before. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = + * ibset(nacc(ivx,nnl(ivx)),19) + ndoub = 1 + call getchar(lineq,iccount,durq) + else if (durq .eq. 'd') then + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + call getchar(lineq,iccount,durq) + end if +c +c Only other possibilities here are ' ' or 'n' +c + if (durq .eq. 'n') then +c +c Alter xtup number +c + if (lineq(iccount+1:iccount+1) .eq. ' ') then +c +c If the only modifier is 'n', cancel the number +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),31) + else + numshft = 0 +30 call getchar(lineq,iccount,durq) + if (durq .eq. 'f') then +c +c Flip up-down-ness +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),14) + go to 30 + else if (index('+-',durq) .gt. 0) then +c +c Vertical or horiz shift +c + numshft = numshft+1 + iofforn = 1 + if (durq .eq. '-') iofforn = -1 + iccount = iccount+1 + call readnum(lineq,iccount,durq,xofforn) + iccount = iccount-1 + if (numshft .eq. 1) then +c +c Vertical shift +c + iofforn = iofforn*nint(xofforn) + 16 +c +c Turn on bit 1; set bits 2-6 to iofforn +c + irest(ivx,nnl(ivx)) = + * ior(irest(ivx,nnl(ivx)),2+4*iofforn) + else +c +c Horizontal shift +c + iofforn = iofforn*nint(xofforn*10)+16 + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),7) + call setbits(irest(ivx,nnl(ivx)),5,9,iofforn) + end if + go to 30 + else if (durq .eq. 's') then +c +c Slope adjustment for bracket +c + mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),4) + call getchar(lineq,iccount,durq) + iofforn = index('- +',durq)-2 + iccount = iccount+1 + call readnum(lineq,iccount,durq,xofforn) + iccount = iccount-1 + iofforn = nint(iofforn*xofforn+16) + call setbits(mult(ivx,nnl(ivx)),5,5,iofforn) + else if (index('123456789',durq) .gt. 0) then +c +c Replacement printed number +c + call readnum(lineq,iccount,durq,xofforn) + call setbits(nacc(ivx,nnl(ivx)),5,22,nint(xofforn)) + iccount = iccount-1 + go to 30 + end if + end if + end if +c +c Set note level of 1st note of xtup, provided not a rest +c + if (.not.btest(irest(ivx,nnl(ivx)),0)) then + if (numnum .eq. 2) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + nolev(ivx,nnl(ivx)) = lastlev + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + nolev(ivx,nnl(ivx)) = lastlev + end if + end if + do 40 npreslur = npreslur , 1 , -1 +c +c Set note level for preslur on starting note of xtuplet +c + call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev) +40 continue + numnum = 0 + nodur(ivx,nnl(ivx)) = 0 + do 6 itup = 2 , ntup + if (ornrpt) then + iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)), + * iand(iornq(ivx,nnl(ivx)-1),10026991)) + if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then +c +c This is a trill (bit 7 or 15) so must dup the parameters +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = nnl(ivx) + xnsktr(ntrill) = xnsktr(ntrill-1) + end if + end if + nnl(ivx) = nnl(ivx)+1 + if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30) +7 call getchar(lineq,iccount,charq) + if (charq .eq. ' ') then + go to 7 + else if (charq .eq. '%') then + iccount = 128 + go to 7 + else if (charq .eq. 'o') then +c +c Ornament in xtuplet. "o" symbol must come AFTER the affected note +c + if (notcrd) then + nole = nolev(ivx,nnl(ivx)-1) + else + nole = iand(127,ishft(icrdat(ncrd),-12)) + end if + call getorn(lineq,iccount,iornq(ivx,nnl(ivx)-1), + * iornq(ivx,0),ornrpt,noffseg, + * nnl(ivx)-1,ivx,.false.,notcrd,nole) + go to 7 + else if (index('st(){}',charq) .gt. 0) then + nnlivx = nnl(ivx)-1 + if (charq.eq.'(' .or. charq.eq.'{') then +c +c Detected preslur in xtuplet loop, non-chord note +c + nnlivx = nnlivx+1 + npreslur = npreslur+1 + end if + islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0) + if (charq.eq.'t') islur(ivx,nnlivx) = + * ibset(islur(ivx,nnlivx),1) + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + if (fontslur) then + call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2, + * isdat3,nsdat,notcrd,nolev(ivx,nnlivx),charq) + else + call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2, + * isdat3,isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq) + end if + go to 7 + else if (charq .eq. 'G') then +c +c Kluge to get grace in xtup at right location +c + nnl(ivx) = nnl(ivx)-1 + call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, + * lastlev,iv,nv) + nnl(ivx) = nnl(ivx)+1 + go to 7 + else if (charq .eq. sq) then + call littex(islur,nnl(ivx),ivx,topmods,lineq,iccount) + go to 7 + else if (index('0123456789#-nx_',charq) .gt. 0) then +c +c Figure. Must come AFTER the first note of xtup +c + ivf = 1 + if (ivx .gt. 1) then + if (ivxfig2 .eq. 0) then + ivxfig2 = ivx + else if (ivx .ne. ivxfig2) then + print* + print*,'Figures not allowed in >1 voice above first' + stop + end if + ivf = 2 + end if + nfig1 = nfigs(ivf)+1 + call getfig(itoff(ivf,nfig1),charq,lineq,iccount, + * isfig(ivf,nnl(ivx)-1),itfig(ivf,nfig1),itsofar(ivx), + * 0,figq(ivf,nfig1),ivupfig(ivf,nfig1),nfigs(ivf)) + go to 7 + else if (charq .eq. 'X') then + call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx)-1)), + * shifton,wheadpt,iornq(ivx,nnl(ivx)),ivx, + * irest(ivx,nnl(ivx)),itsofar(ivx),ntup,itup,nnodur, + * dotq,ndoub) + go to 7 + else if (charq .eq. 'z') then +c +c Chord note in xtup. Goes with *prior* note. +c + notcrd = .false. + ncrd = ncrd+1 + ipl(ivx,nnl(ivx)-1) = ibset(ipl(ivx,nnl(ivx)-1),10) + numnum = 0 +c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) + icrdat(ncrd) = nnl(ivx)-1 + call setbits(icrdat(ncrd),4,8,mod(ivx,16)) + if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28) + icrdorn(ncrd) = 0 +c +c Get note name +c + call getchar(lineq,iccount,charq) +c +c Get optional inputs +c +34 call getchar(lineq,iccount,durq) +c +c When chord note is done, will get ' ', making ndx=0, so go past this block +c + ndx = index('fsn+-<>12345678reic',durq) + if (ndx .gt. 0) then + if (ndx .le. 3) then + if (.not.btest(icrdat(ncrd),19)) then + icrdat(ncrd) = ibset(icrdat(ncrd),19) + icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20)) + else + icrdat(ncrd) = ibset(icrdat(ncrd),22) + end if + else if (ndx .eq. 19) then +c +c Set flags for cautionary accidental +c + icrdat(ncrd) = ibset(icrdat(ncrd),31) + iornq(ivx,nnl(ivx)-1) = + * ibset(iornq(ivx,nnl(ivx)-1),31) + else if (ndx .le. 7) then +c +c +/-/</> Check whether octave or accidental shift +c + nactmp = 0 + call chkpm4ac(lineq,iccount,nactmp,moved) + if (moved) then +c +c Transfer accidental shift values +c + call setbits(icrdot(ncrd),6,14, + * igetbits(nactmp,6,4)) + call setbits(icrdot(ncrd),7,20, + * igetbits(nactmp,7,10)) + else + if (durq .eq. '+') then + lastlev = lastlev+7 + else if (durq .eq. '-') then + lastlev = lastlev-7 + end if + end if + else if (durq .eq. 'e') then + icrdat(ncrd) = ibset(icrdat(ncrd),23) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + else if (durq .eq. 'r') then + icrdat(ncrd) = ibset(icrdat(ncrd),24) + irest(ivx,nnl(ivx)-1) = + * ibset(irest(ivx,nnl(ivx)-1),20) + else if (durq .eq. 'i') then +c +c Midi-only accidental +c + icrdat(ncrd) = ibset(icrdat(ncrd),27) + else +c +c must be a number, save it in ioct +c + numnum = 1 + ioct = ndx-7 + end if + go to 34 + end if + if (numnum .eq. 1) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + end if + icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12)) + do 41 npreslur = npreslur , 1 , -1 +c +c Set note level for preslur on chord note in xtup +c + call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) +c +c Following lines copied from loop for non-xtup, chord note, preslur +c Initially I assigned the slur(s) to next note, so fix. +c + islur(ivx,nnl(ivx)) = ibclr(islur(ivx,nnl(ivx)),0) + islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),0) + isdat2(nsdat-npreslur+1) = + * ibset(isdat2(nsdat-npreslur+1),0) + call setbits(isdat1(nsdat-npreslur+1),8,3, + * igetbits(isdat1(nsdat-npreslur+1),8,3)-1) +41 continue + go to 7 + else if (charq .eq. '?') then +c +c Arpeggio +c + if (btest(ipl(ivx,nnl(ivx)-1),10)) then +c +c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note +c of chord, will not set icrdat(25), but iornq(27) +c + icrdat(ncrd) = ibset(icrdat(ncrd),25) + else + iornq(ivx,nnl(ivx)-1) = ibset(iornq(ivx,nnl(ivx)-1),27) + end if +c +c Check for shift +c + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + else +c +c durq must be "-" +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 +c +c record the shift +c + NumArpShift = NumArpShift+1 + IvArpShift(NumArpShift) = ivx + IpArpShift(NumArpShift) = nnl(ivx)-1 + ArpShift(NumArpShift) = fnum + end if + go to 7 + else if (charq .eq. 'D') then + call getdyn(ivx,nnl(ivx)-1,irest(ivx,nnl(ivx)-1), + * iornq(ivx,nnl(ivx)-1),lineq,iccount) + go to 7 +c+++ + else if (charq .eq. ']') then +c +c Multiplicity up-down, must have '][ ' +c + islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),20) + iccount = iccount+2 + go to 7 +cc+++ + end if +c +c End of loop for xtup options. If here, charq must be a (non-crd) note name. +c or rest +c + if (charq .eq. 'r') then +c +c Rest in xtup +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0) + if (index('+-b',lineq(iccount+1:iccount+1)) .gt. 0) then + call getchar(lineq,iccount,durq) + if (durq .eq. 'b') then +c +c Blank rest in middle of xtup +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29) + else +c +c Override height of embedded xtup rest +c + ipm = index('- +',durq)-2 + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum) + iccount = iccount-1 + end if + else if (ivx .le. nv) then + nolev(ivx,nnl(ivx)) = 0 + else + nolev(ivx,nnl(ivx)) = 2 + end if + end if + notcrd = .true. +8 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then + if (index('+-<>',durq) .gt. 0) then +c +c Accidental horizontal shift +c + call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved) + if (.not.moved) then + if (durq.eq.'+') then + lastlev = lastlev+7 + else if (durq.eq.'-') then + lastlev = lastlev-7 + end if + end if + else if (index('fsn',durq) .gt. 0) then + if (nacc(ivx,nnl(ivx)) .eq. 0) then +c +c No accid set yet +c + nacc(ivx,nnl(ivx)) = index('fsn',durq) + else +c +c Symbol must be repeated, so it's a double +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2) + end if + else if (durq .eq. 'i') then +c +c Set flag for midi-only accidental +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),17) + + else if (durq .eq. 'c') then +c +c Set flags for cautionary accidental +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),31) + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) + else if (index('ul',durq) .gt. 0) then +c +c Force stem direction for non-beamed xtup note +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30) + if (durq .eq. 'u') islur(ivx,nnl(ivx)) = + * ibset(islur(ivx,nnl(ivx)),17) + else if (durq .eq. 'e') then +c +c Left-shift main xtup note +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + else if (durq .eq. 'r') then +c +c Right-shift main xtup note +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) + else if (index('DF',durq) .gt. 0) then +c +c Double an xtup note to make an unequal xtup +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = + * ibset(nacc(ivx,nnl(ivx)),19) + ndoub = ndoub+1 + else if (durq .eq. 'd') then +c +c Dotted xtup note +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),27) + else +c +c Must be an octave number +c + lastlev = ifnolev(charq,ichar(durq)-48 + * ,iTransAmt(instno(iv))) + end if + go to 8 + end if + if (itup .lt. ntup) then +c +c Last note is handled *after* flowing out of the xtup if block, but still +c within block for a note-rest. Set note level now (rest already done). +c Could have problem here if rests & doubled notes are combined in xtup, +c since might exit the loop at the wrong place. Worry about it later. +c + if (.not.btest(irest(ivx,nnl(ivx)),0)) then + lastlev = lastlev-3+mod(ifnolev(charq,10, + * iTransAmt(instno(iv)))-lastlev+3,7) + nolev(ivx,nnl(ivx)) = lastlev + end if + nodur(ivx,nnl(ivx)) = 0 + do 42 npreslur = npreslur , 1 , -1 +c +c Set note level for preslur on internal xtup note +c + call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) +42 continue + end if + if (itup .eq. ntup-ndoub) go to 12 +6 continue +12 continue + if (ornrpt) then + iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)), + * iand(iornq(ivx,nnl(ivx)-1),10026991)) + if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then +c +c This is a trill (bit 7 or 15) so must dup the parameters +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = nnl(ivx) + xnsktr(ntrill) = xnsktr(ntrill-1) + end if + end if +c +c End of if-block for xtuplet input +c + else if (durq .eq. 'm') then +c +c Multi-bar rest: next 1 or two digits are # of bars. +c For some purposes, pretend its one bar only +c + nodur(ivx,nnl(ivx)) = lenbar + ibarmbr = nbars+1 + mbrest = 0 + xb4mbr = 0. +20 call getchar(lineq,iccount,durq) + if (ichar(durq).ge.48.and.ichar(durq).le.57) then + mbrest = 10*mbrest+ichar(durq)-48 + go to 20 + end if + else if (index('ul',durq) .gt. 0) then +c +c Set stem flipper +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30) + if (durq .eq. 'u') islur(ivx,nnl(ivx)) = + * ibset(islur(ivx,nnl(ivx)),17) + go to 2 + else if (durq .eq. 'a') then +c +c "Alone", i.e., prohibit beam +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),18) + go to 2 + else if (durq .eq. 'r') then +c +c Right offset by one notehead +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) + go to 2 + else if (durq .eq. 'e') then +c +c Left offset by one notehead +c + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + go to 2 + else if (durq .eq. 'S') then +c +c Stemlength change. Get -dstemlen in \internotes. Allowable values are .5 to 4 +c Set mult(27). Map value to 0 to 7, store in mult(28-30). Later convert to +c interbeams = internotes*2/3. +c + mult(ivx,nnl(ivx)) = ibset(mult(ivx,nnl(ivx)),27) + call getchar(lineq,iccount,durq) + if (durq .eq. ':') then +c +c End stickyS. Grab data now from prior note, since we have to shut off stickyS. +c + call setbits (mult(ivx,nnl(ivx)),3,28, + * igetbits(mult(ivx,nnl(ivx)-1),3,28)) + stickyS = .false. + go to 2 + end if +c +c If durq .ne. ':' then iccount is now on the start of the number +c + call readnum(lineq,iccount,durq,dum) + call setbits (mult(ivx,nnl(ivx)),3,28,nint((dum-.5)*2)) + if (durq .eq. ':') then + stickyS = .true. + else + iccount = iccount-1 + end if + go to 2 + else if (durq .eq. ',') then +c +c 2:1 pattern +c + idotform = 3 +c +c Now flow to duration setting, as if durq=' ' +c + else if (durq .eq. '.') then +c +c Dotted pattern. Close out note. Mult time by 3/4. +c Set time for next note to 1/4. Start the note. +c + idotform = 1 + else if (durq .eq. 'o') then +c +c Suppress rest centering +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),25) + go to 2 + else if (durq .eq.'L') then +c +c With keyboard rest option, look left +c + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),30) + go to 2 + else if (index('DF',durq) .gt. 0) then +c +c Double note for xtup. Must check here in case "D" came before "x" or on +c last note of xtup. Need to flag it in pmxa since affects horiz. spacing. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),18) + if (durq .eq. 'F') nacc(ivx,nnl(ivx)) = + * ibset(nacc(ivx,nnl(ivx)),19) + go to 2 + else if (durq .eq. 'A') then +c +c Accidental option +c + call getchar(lineq,iccount,durq) +c + if (durq .eq. 'o') then +c +c Ordered accidentals in a chord. Mark the main note. +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),28) + else +c +c Only other possibility is +-<> . Set tag, reduce iccount and loop to get #'s +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),29) + iccount = iccount-1 + end if + go to 2 + else if (durq .ne. ' ') then + print*,'Illegal character in note: ',durq,', ivx,nn:', + * ivx,nnl(ivx) + call stop1() + end if +c +c Done with note/rest options. Set level and duration. +c + if (.not.btest(irest(ivx,nnl(ivx)),0)) then + if (numnum .eq. 2) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + nolev(ivx,nnl(ivx)) = lastlev + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + nolev(ivx,nnl(ivx)) = lastlev + end if + do 43 npreslur = npreslur , 1 , -1 +c +c Set level for preslur on normal note, non-chord +c + call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev) +43 continue + end if + if (idotform .gt. 0) then + if (idotform .eq. 1) then + nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)*3/2 + else if (idotform .eq. 2) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3 + else if (idotform .eq. 3) then + nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq) + else if (idotform .eq. 4) then + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2 + end if + else if (btest(islur(ivx,nnl(ivx)),19)) then +c +c Set duration of full-bar rest as pause +c + nodur(ivx,nnl(ivx)) = lenbar +c +c Use a one-line function to set nnodur. It gives inverse of ifnodur. +c + nnodur = index('62514x0x37', + * chax(48+int(log(.1+lenbar)/.69315)))-1 + else if (ibarmbr.ne.nbars+1) then + nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq) + if (btest(islur(ivx,nnl(ivx)),3)) + * nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6 + end if + if (shifton .and. .not.btest(irest(ivx,nnl(ivx)),16)) then +c +c Shift is on, and this is not first shifted note. Check for duration change +c + if (nodur(ivx,nnl(ivx)) .ne. nodur(ivx,nnl(ivx)-1)) then +c +c Must stop and restart the offset. +c + irest(ivx,nnl(ivx)-1) = ibset(irest(ivx,nnl(ivx)-1),17) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),16) + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = udoff(ivx,nudoff(ivx)-1) + end if + end if + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + if (autofbon .and. tautofb.gt.tol .and. fbon) then +c +c Check to see if need to terminate auto forced beam +c + if (mod(itsofar(ivx)-t1autofb,tautofb) .lt. tol) then +c +c Terminate autofb +c + t2fb(ivx,nfb(ivx)) = itsofar(ivx) + fbon = .false. + end if + end if + if (mod(itsofar(ivx)-lenb0,lenbar) .eq. 0) then +c +c Finished a bar +c + nbars = nbars+1 + nib(ivx,nbars) = nnl(ivx) + if (firstgulp.and.lenb0.ne.0.and.nbars.eq.1) then +c +c Just finished the pickup bar for this voice. +c + lenbar = lenb1 + end if + end if + if (idotform .eq. 1) then + call getchar(lineq,iccount,charq) + idotform = 2 + numnum = 1 + go to 28 + else if (idotform .eq. 3) then + call getchar(lineq,iccount,charq) + idotform = 4 + numnum = 1 + go to 28 + end if +c +c End of sub block for note-rest +c + else if (charq .eq. 'z') then +c +c Chord note. Must have note name, may have octave#,+,-,s,f,n,d +c Actually the 'd' is not used, since time value comes from +c basic note. Unless dot is to be shifted! +c Doesn't increase # of notes, so must handle separately +c ncrd: index of crd +c Set bit 10 of ipl on main note as flag +c Bits in icrdat: +c 0-7 ip within voice +c 8-11 ivx +c 12-18 note level +c 19 accidental? +c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp) +c 23 shift left +c 24 shift right +c 25 arpeggio start or stop +c 26 flag for moved dot (here, not icrdot, since this is always reset!) +c 27 Midi-only accidental +c 29 Tag for accidental shift...means add to autoshifts. +c 31 Cautionary accidental +c +c Bits in icrdot: +c 0-6 10*abs(vertical dot shift in \internote) + 64 +c 7-13 10*abs(horizontal dot shift in \internote) + 64 +c 14-19 vert accidental shift-32 +c 20-26 20*(horiz accidental shift+3.2) +c 27-29 top-down level rank of chord note w/accid. Set in crdaccs. +c +c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds. +c + ncrd = ncrd+1 + ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),10) + numnum = 0 +c icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) + icrdat(ncrd) = nnl(ivx) + call setbits(icrdat(ncrd),4,8,mod(ivx,16)) + if (ivx .ge. 16) icrdat(ncrd) = ibset(icrdat(ncrd),28) + icrdot(ncrd) = 0 + icrdorn(ncrd) = 0 +c +c Get note name +c + call getchar(lineq,iccount,charq) +c +c Get optional inputs +c +25 call getchar(lineq,iccount,durq) +c ndx = index('fsn+-<>12345678rediA',durq) + ndx = index('fsn+-<>12345678rediAc',durq) + if (ndx .eq. 20) then +c +c Expect +|-|<|> , set tag, loop +c + icrdat(ncrd) = ibset(icrdat(ncrd),29) + go to 25 + else if (ndx .gt. 0) then + if (ndx .le. 3) then + if (.not.btest(icrdat(ncrd),19)) then + icrdat(ncrd) = ibset(icrdat(ncrd),19) + icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20)) + else + icrdat(ncrd) = ibset(icrdat(ncrd),22) + end if + else if (ndx .eq. 21) then +c +c Set flags for cautionary accidental +c + icrdat(ncrd) = ibset(icrdat(ncrd),31) + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),31) + else if (ndx .le. 7) then +c +c +/-/</> Check whether octave or accidental shift +c + nactmp = 0 + call chkpm4ac(lineq,iccount,nactmp,moved) + if (moved) then +c +c Transfer accidental shift values +c + call setbits(icrdot(ncrd),6,14,igetbits(nactmp,6,4)) + call setbits(icrdot(ncrd),7,20,igetbits(nactmp,7,10)) + else + if (durq .eq. '+') then + lastlev = lastlev+7 + else if (durq .eq. '-') then + lastlev = lastlev-7 + end if + end if + else if (durq .eq. 'e') then + icrdat(ncrd) = ibset(icrdat(ncrd),23) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27) + else if (durq .eq. 'r') then + icrdat(ncrd) = ibset(icrdat(ncrd),24) + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20) + else if (durq .eq. 'i') then +c +c Midi-only accidental on chord note +c + icrdat(ncrd) = ibset(icrdat(ncrd),27) + else if (durq .eq. 'd') then +c +c Must keep 'd' optional (backward compatibility), unless it is moved! +c + if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then +c +c move a dot, unless next char is not part of a number +c + if (index('0123456789.',lineq(iccount+2:iccount+2)) + * .eq. 0) go to 25 + icrdat(ncrd) = ibset(icrdat(ncrd),26) + call getchar(lineq,iccount,durq) + iccount=iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (durq .eq. '+') then + icrdot(ncrd) = ior(icrdot(ncrd),nint(fnum*10)+64) + else + icrdot(ncrd) = ior(icrdot(ncrd),-nint(fnum*10)+64) + end if + if (index('+-',dumq) .gt. 0) then +c +c Vertical shift specified also +c + iccount=iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (dumq .eq. '+') then + ifnum = nint(fnum*10)+64 + else + ifnum = -nint(fnum*10)+64 + end if + else + ifnum = 64 + end if + icrdot(ncrd) = ior(icrdot(ncrd),ishft(ifnum,7)) + iccount = iccount-1 + end if + else +c +c must be a single digit, save it in ioct +c + numnum = 1 + ioct = ndx-7 + end if + go to 25 + end if + if (numnum .eq. 1) then + lastlev = ifnolev(charq,ioct,iTransAmt(instno(iv))) + else + lastlev = lastlev-3 + * +mod(ifnolev(charq,10,iTransAmt(instno(iv)))-lastlev+3,7) + end if + icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12)) + do 44 npreslur = npreslur , 1 , -1 + call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev) +c +c Set level for chord note. +c Initially I assigned the slur(s) to next note, so fix. +c + islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),0) + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),0) + isdat2(nsdat-npreslur+1) = ibset(isdat2(nsdat-npreslur+1),0) + call setbits(isdat1(nsdat-npreslur+1),8,3, + * igetbits(isdat1(nsdat-npreslur+1),8,3)-1) +44 continue + if (notcrd) then +c +c This is the first chord note in this chord. +c + minlev = min(nolev(ivx,nnl(ivx)),lastlev) + maxlev = max(nolev(ivx,nnl(ivx)),lastlev) + else + minlev = min(minlev,lastlev) + maxlev = max(maxlev,lastlev) + end if + notcrd = .false. + else if (charq .eq. 'G') then + call getgrace(ivx,nnl,lineq,iccount,islur,iornq,ipl,ndlev, + * lastlev,iv,nv) + continue +c +c Grace, comes *before* main note: +c UNLESS there's an 'A' or 'W' after the 'G' +c ngrace = # of grace note groups so far in block +c ivg(ngrace), ipg(ngrace) +c nng(ngrace) = # of notes in this group: default = 1 +c ngstrt(ngrace) = starting position in nolevg of levels for this grace +c multg(ngrace) = multiplicity: default = 1; input as 'm(digit)' +c upg(ngrace) = logical for beam or stem dirn: default T, input'u,l' +c slurg(ngrace) = logical for slur; default F, input 's' +c slashg(ngrace) = T if slash; default is F, input 'x' +c These data MUST precede note name of first note +c nolevg, naccg: lists of levels and accid's, indexed as described above. +c +c ngrace = ngrace+1 +c ivg(ngrace) = ivx +c ipg(ngrace) = nnl(ivx)+1 +c if (ngrace .eq. 1) then +c ngstrt(ngrace) = 1 +c else +c ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1) +c end if +c islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4) +c nng(ngrace) = 1 +c multg(ngrace) = 1 +c upg(ngrace) = .true. +c slurg(ngrace) = .false. +c slashg(ngrace) = .false. +c18 call getchar(lineq,iccount,charq) +c if (index('WA',charq) .gt. 0) then +cc +cc Grace is on note that was already done, so shift flags forward one note. +cc This puts flag on actual note with grace; later for W will go ahead one more. +cc +c ipg(ngrace) = nnl(ivx) +c islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4) +c islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4) +c if (slurg(ngrace)) +c * iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24) +c if (charq .eq. 'A') then +cc +cc close After, clear way-after bit, to ensure priority of most recent A/W +cc +c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29) +c else +cc +cc Way after; later assign to following note, and position like normal grace. +cc +c ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31) +c end if +c else if (charq .eq. 'm') then +c call getchar(lineq,iccount,charq) +c multg(ngrace) = ichar(charq)-48 +c else if (index('123456789',charq) .gt. 0) then +c call readnum(lineq,iccount,durq,fnum) +c iccount = iccount-1 +c nng(ngrace) = nint(fnum) +c else if (charq .eq. 'l') then +c upg(ngrace) = .false. +c else if (charq .eq. 's') then +c slurg(ngrace) = .true. +c if (nnl(ivx) .gt. 0) then +cc +cc If A- or W-grace, set signal to start slur on main note. +cc +c if(btest(ipl(ivx,nnl(ivx)),31) .or. +c * btest(ipl(ivx,nnl(ivx)),29)) +c * iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24) +c end if +c else if (charq .eq. 'x') then +c slashg(ngrace) = .true. +c else if (charq .eq. 'u') then +c else if (charq .eq. 'X') then +cc +cc Space before main note of grace. Number will come next. +cc +c iccount = iccount+1 +c call readnum(lineq,iccount,durq,graspace(ngrace)) +c iccount = iccount-1 +c end if +c if (index('abcdefg',charq) .eq. 0) go to 18 +cc +cc At this point, charq is first note name in grace +cc +c do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1 +c naccg(ing) = 0 +c ioct = 0 +c if (ing .gt. ngstrt(ngrace)) then +c55 call getchar(lineq,iccount,charq) +c if (charq .eq. ' ') go to 55 +c endif +c iclastlev = 0 +c9 call getchar(lineq,iccount,durq) +c if (durq .ne. ' ') then +c if (durq.eq.'+') then +c lastlev = lastlev+7 +c iclastlev = iclastlev+7 +c else if (durq.eq.'-') then +c lastlev = lastlev-7 +c iclastlev = iclastlev-7 +c else if (index('fsn',durq) .gt. 0) then +c if (naccg(ing) .eq. 0) then +c naccg(ing) = index('fsn',durq) +c else +cc +cc Double accidental +cc +c naccg(ing) = ibset(naccg(ing),2) +c end if +c else +c ioct = ichar(durq)-48 +c end if +c go to 9 +c end if +c if (ioct .gt. 0) then +c lastlev = ifnolev(charq,ioct) +c else +c if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then +c if (ivx .le. nv) then +c kv = 1 +c else +c kv = 2 +c end if +c lastlev = ndlev(iv,kv)+iclastlev +c end if +c lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7) +c end if +c nolevg(ing) = lastlev +c19 continue +cc +cc Grace could come before first note of block, so reset end level. +cc +c if (nnl(ivx).eq.0) then +c if (ivx .le. nv) then +c kv = 1 +c else +c kv = 2 +c end if +c ndlev(iv,kv) = lastlev +c end if + else if (charq .eq. sq) then +c +c Literal TeX string +c + call littex(islur,nnl(ivx)+1,ivx,topmods,lineq,iccount) + else if (charq .eq. 'o') then +c +c Ornament on non-xtup note. Symbol must come AFTER the affected note +c + if (notcrd) then + nole = nolev(ivx,nnl(ivx)) + else + nole = iand(127,ishft(icrdat(ncrd),-12)) + end if + call getorn(lineq,iccount,iornq(ivx,nnl(ivx)), + * iornq(ivx,0),ornrpt,noffseg,nnl(ivx),ivx, + * .true.,notcrd,nole) + else if (index('st(){}',charq) .gt. 0) then + nnlivx = nnl(ivx) + if (charq.eq.'(' .or. charq.eq.'{') then +c +c Detect preslur on normal non-chord note +c + nnlivx = nnlivx+1 + npreslur = npreslur+1 + end if + islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0) + if (charq.eq.'t') + * islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),1) + if (ivx .le. nv) then + kv = 1 + else + kv = 2 + end if + if (fontslur) then + call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3, + * nsdat,notcrd,nolev(ivx,nnlivx),charq) + else + call spsslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3, + * isdat4,nsdat,notcrd,nolev(ivx,nnlivx),charq) + end if + else if (charq .eq. '?') then +c +c Arpeggio +c + if (btest(ipl(ivx,nnl(ivx)),10)) then +c +c This is a chordal note. Set a bit in icrdat. But if *main* (spacing) note +c of chord, will not set icrdat(25), but iornq(27) +c + icrdat(ncrd) = ibset(icrdat(ncrd),25) + else + iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),27) + end if +c +c Check for shift +c + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + iccount = iccount-1 + else +c +c durq must be "-" +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 +c +c record the shift +c + NumArpShift = NumArpShift+1 + IvArpShift(NumArpShift) = ivx + IpArpShift(NumArpShift) = nnl(ivx) + ArpShift(NumArpShift) = fnum + end if + else if (index('0123456789#-nx_',charq) .gt. 0) then +c +c We have a figure. Must come AFTER the note it goes under +c + + ivf = 1 + if (ivx .gt. 1) then + if (ivxfig2 .eq. 0) then + ivxfig2 = ivx + else if (ivx .ne. ivxfig2) then + print* + print*,'Figures not allowed in >1 voice above first' + stop + end if + ivf = 2 + end if + nfig1 = nfigs(ivf)+1 + call getfig(itoff(ivf,nfig1),charq,lineq,iccount, + * isfig(ivf,nnl(ivx)),itfig(ivf,nfig1),itsofar(ivx), + * nodur(ivx,nnl(ivx)),figq(ivf,nfig1), + * ivupfig(ivf,nfig1),nfigs(ivf)) + else if (charq .eq. '[') then +c +c Start forced beam. Record barno & time since start of inp. blk. Set signal +c + nfb(ivx) = nfb(ivx)+1 + fbon = .true. + ulfbq(ivx,nfb(ivx)) = 'x' + t1fb(ivx,nfb(ivx)) = itsofar(ivx) + nadj = 0 + if (autofbon) then + autofbon = .false. + end if +17 call getchar(lineq,iccount,charq) + if (index('ulf',charq) .gt. 0) then + ulfbq(ivx,nfb(ivx)) = charq + go to 17 + else if (charq .eq. 'j') then +c +c Continuing a jumped beam here +c + irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),24) +c +c Set flag to watch for END of this forced beam, so can set flag rest(30) on +c NEXT note as signal to start a new notes group there. +c + isbj2 = .true. + go to 17 + else if (charq .eq. 'h') then + islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),2) + go to 17 + else if (charq .eq. 'm') then +c +c Force multiplicity. Next input is digit +c + call getchar(lineq,iccount,charq) + islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),21) + call setbits(islur(ivx,nnl(ivx)+1),3,22,ichar(charq)-48) + go to 17 + else if (charq .eq. ':') then +c +c Start auto forced beam pattern +c + autofbon = .true. +c +c When forced later beam ends, check whether tautofv <=0; if so set it. +c + tautofb = -itsofar(ivx) + t1autofb = itsofar(ivx) + go to 17 + else if (charq .ne. ' ') then +c +c Must be '+/-' for height or slope shift +c + nadj = nadj+1 +c +c nadj = 1,2, or 3 for normal start level, slope, or beam-thk start level. +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + iadj = nint(fnum) + if (charq .eq. '-') iadj = -iadj + if (nadj .eq. 1) then +c +c This is a level shift. Note if 0 was entered, iadj = 30 +c + call setbits(ipl(ivx,nnl(ivx)+1),6,11,iadj+30) + else if (nadj .eq. 2) then +c +c Must be a slope shift +c + call setbits(ipl(ivx,nnl(ivx)+1),6,17,iadj+30) + else +c +c Beam-thk fine tune +c + call setbits(islur(ivx,nnl(ivx)+1),2,27,iadj) + end if + go to 17 + end if + else if (charq .eq. ']') then + if (autofbon .and. tautofb.lt.tol) then + tautofb=itsofar(ivx)+tautofb + end if + call getchar(lineq,iccount,charq) + if (index('j ',charq) .gt. 0) then +c +c Since ']' comes AFTER note, itsofar has been updated. Set ending signal. +c + t2fb(ivx,nfb(ivx)) = itsofar(ivx) + fbon = .false. + if (charq .eq. 'j') + * irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),23) + if (isbj2) then +c +c This is the end of a fb segment of a jump beam. Set flag on NEXT note to +c force start of new notes group, provided this is not last note in bar. +c + if (mod(itsofar(ivx),lenbar) .ne. 0) + * irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),30) + isbj2 = .false. + end if + else if (charq .eq. '[') then +c +c Multiplicity down-up signal +c + islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),20) + else if (charq .eq. '-') then +c +c Set signals for gap in single-slope beam [...]-[...] +c + nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),20) + nacc(ivx,nnl(ivx)+1) = ibset(nacc(ivx,nnl(ivx)+1),21) +c +c Next two characters must be "[ ". Skip over them. +c + iccount = iccount+2 + end if + else if (charq .eq. 'D') then + call getdyn(ivx,nnl(ivx),irest(ivx,nnl(ivx)), + * iornq(ivx,nnl(ivx)),lineq,iccount) + else if (charq .eq. 'h') then +c +c Heading or height. For heading, only OK if at start of block +c Check whether at beginning of a block +c + if (iv.ne.1 .or. nnl(1).ne.0) then + print*,'You entered "h" not at beginning of block' + call stop1() + end if + call getchar(lineq,iccount,durq) + ihdvrt = 0 + if (index('+-',durq) .gt. 0) then +c +c Vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + ihdvrt = fnum+.1 + if (durq .eq. '-') ihdvrt = -ihdvrt + durq = charq + end if + if (durq .ne. ' ') then +c +c Height symbol. Read past (until next blank) +c +3 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') go to 3 + else +c +c Set flag for header & read it in +c + ihdht = 16 + call getbuf(headrq) + iccount = 128 + end if + else if (charq .eq. 'L') then +c +c Linebreak, already handled in pmxa, but check for movement break +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fmovbrk) + if (durq .eq. 'P') then + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + end if + if (durq .eq. 'M') then + movbrk = nint(fmovbrk) + movgap = 0 + parmov = -1. + call getchar(lineq,iccount,durq) +31 if (durq .eq. '+') then +c +c Get vertical space (\internotes) +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + movgap = nint(fnum) + go to 31 + else if (durq .eq. 'i') then + iccount = iccount+1 + call readnum(lineq,iccount,durq,parmov) + go to 31 + else if (durq .eq. 'c') then + nobar1 = .true. + call getchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'r') then +c +c "rename" can be set on or off. +c + call getchar(lineq,iccount,durq) + rename = durq.eq.'+' + call getchar(lineq,iccount,durq) + go to 31 + else if (durq .eq. 'n') then +c +c Change # of voices. Input ninow, iiorig(1...ninow). Will use names, +c staves per inst. and clefs corr. to iiorig in original list of instruments. +c + nvold = nv + nv = 0 + rename = .true. + call getchar(lineq,iccount,durq) + if (durq .eq. ':') then + iccount = iccount+2 + read(lineq(iccount-1:iccount),'(i2)')ninow + else + ninow = ichar(durq)-48 + end if + iiv = 0 + do 63 iinow = 1 , ninow + call getchar(lineq,iccount,durq) + if (durq .eq. ':') then + iccount = iccount+2 + read(lineq(iccount-1:iccount),'(i2)')iiorig(iinow) + else + iiorig(iinow) = ichar(durq)-48 + end if + nspern(iinow) = nsperi(iiorig(iinow)) + nv = nv+nspern(iinow) + sepsymq(iiv+nspern(iinow)) = '&' + if (nspern(iinow) .gt. 1) then + do 64 iis = 1 , nspern(iinow)-1 + sepsymq(iiv+iis) = '|' +64 continue + end if + iiv = iiv+nspern(iinow) +63 continue +c +c 120818 Per Rainer's suggestion, defer changing \nbinstruments until issuing \newmovement +c +c if (islast) then +c if (ninow .lt. 10) then +c write(11,'(a)')sq//'newnoi{'//chax(ninow+48)//'}%' +c else +c write(11,'(a8,i2,a2)')sq//'newnoi{',ninow,'}%' +c end if +c end if + if (nv.eq.1 .and. nvold.gt.1) then + if (islast) write(11,'(a)')sq//'nostartrule' + else if (nv.gt.1 .and. nvold.eq.1) then + if (islast) write(11,'(a)')sq//'startrule' + end if + iiv = 0 + do 60 iinow = 1 , ninow + do 61 iis = 1 , nspern(iinow) + iiv = iiv+1 +c +c May not really need to re-enter clefs, but it's easier to program since +c clef names are not saved but are needed in newvoice to set ncmidcc. +c + call getchar(lineq,iccount,clefq(iiv)) + call newvoice(iiv,clefq(iiv),.true.) + if (nspern(iinow) .eq. 1) then + hdlndq = chax(48+numclef(clefq(iiv))) + lclf = 1 + else if (iis .eq. 1) then + hdlndq = '{'//chax(48+numclef(clefq(iiv))) + lclf = 2 + else if (iis .lt. nspern(iinow)) then + hdlndq = hdlndq(1:lclf)//chax(48+numclef(clefq(iiv))) + lclf = lclf+1 + else + hdlndq = + * hdlndq(1:lclf)//chax(48+numclef(clefq(iiv)))//'}' + lclf = lclf+2 + end if +61 continue +c +c setstaffs & setclef go by instrument, not voice +c + if (islast) then + if (iinow .lt. 10) then + write(11,'(a)')sq//'setstaffs' + * //chax(48+iinow)//chax(48+nspern(iinow))//'%' + write(11,'(a)')sq//'setclef'//chax(48+iinow) + * //hdlndq(1:lclf)//'%' + else + write(11,'(a11,i2,a)')sq//'setstaffs{',iinow, + * '}'//chax(48+nspern(iinow))//'%' + write(11,'(a9,i2,a)')sq//'setclef{',iinow, + * '}'//hdlndq(1:lclf)//'%' + end if + end if +60 continue +c +c Loop back up, this may not be last option in M. Note flow out if durq=' ' +c + call getchar(lineq,iccount,durq) + go to 31 + end if +c +c Write instrument names +c + if (.not.rename) then + do 62 iinst = 1 , ninow + if (islast) then + if (iinst .lt. 10) then + write(11,'(a8,i1,a3)')sq//'setname',iinst,'{}%' + else + write(11,'(a9,i2,a4)')sq//'setname{',iinst,'}{}%' + end if + end if +62 continue + else + do 65 iinst = 1 , ninow + if (islast) then + if (iinst .lt. 10) then + write(11,'(a8,i1,a)')sq//'setname',iinst,'{'// + * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%' + else + write(11,'(a9,i2,a)')sq//'setname{',iinst,'}{'// + * inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%' + end if + end if +65 continue + rename = .false. + end if + end if + else if (charq .eq.'|' ) then +c +c End of bar symbol. Check about end of bar hardspace. +c + if (btest(iornq(ivx,nnl(ivx)+1),26)) then +c +c There was a hardspace followed by a bar line. Remove it from the hardspace +c list, store with shifts instead, set special bit. Need to repeat this code +c at '/'. +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18) + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = udsp(nudsp) + nudsp = nudsp-1 + iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26) + end if + else if (index('wS',charq) .gt. 0) then +c +c Width symbol or new nsyst. Read past (until blank) +c +4 call getchar(lineq,iccount,durq) + if (durq .ne. ' ') go to 4 + else if (charq .eq. 'l') then +c +c Lower string. Only OK if at start of block +c Check whether at beginning of a block +c + if (iv.ne.1 .or. nnl(1).ne.0) then + print*,'You entered "l" not at beginning of block' + call stop1() + end if +c +c Set flag for lower string & read it in +c + lower = .true. + call getbuf(lowerq) + iccount = 128 + else if (charq .eq. 'm') then +c +c Meter change. Only allow at beginning of block. +c mtrnuml, mtrdenl (logical) and p (printable) will be input. +c mtrnuml=0 initially. (In common) +c +c Check whether at beginning of a block +c + if (iv.ne.1 .or. nnl(1).ne.0) then + print*,'You entered "m" not at beginning of block' + call stop1() + end if + call readmeter(lineq,iccount,mtrnuml,mtrdenl) + call readmeter(lineq,iccount,mtrnmp,mtrdnp) + lenbeat = ifnodur(mtrdenl,'x') + if (mtrdenl .eq. 2) lenbeat = 16 + lenbar = mtrnuml*lenbeat + if (mtrdenl .eq. 2) lenbar = lenbar*2 + lenb1 = lenbar + lenb0 = 0 + if (ismidi) call midievent('m',mtrnuml,mtrdenl) + else if (charq .eq. 'C') then +c +c Clef change on next note. Set bits 11-15. Won't allow in 2nd line of music. +c + if (nnl(iv) .gt. 0) ncc(iv) = ncc(iv)+1 + tcc(iv,ncc(iv)) = itsofar(iv) + isl = ibset(islur(iv,nnl(iv)+1),11) + call getchar(lineq,iccount,durq) +c +c Store clef number, or 7 if clef number = 9 (French violin clef) +c + isl = ior(isl,ishft(min(numclef(durq),7),12)) + ncmidcc(iv,ncc(iv)) = ncmidf(durq) +c +c Set marker on note with lowest voice # starting at same time. +c + if (iv .eq. 1) then + isl = ibset(isl,15) + else + do 13 iiv = 1 , iv + nnliiv = nnl(iiv) + if (iiv .eq. iv) nnliiv = nnliiv+1 + itother = 0 + do 14 iip = 1 , nnliiv + if (itother .lt. itsofar(iv)) then + itother = itother+nodur(iiv,iip) + go to 14 + else if (itother .eq. itsofar(iv)) then + islur(iiv,iip) = ibset(islur(iiv,iip),15) + go to 15 + end if +14 continue +13 continue +15 continue + end if +c +c Need 'or' since may have set bit 15 in the above loop +c + islur(iv,nnl(iv)+1) = ior(isl,islur(iv,nnl(iv)+1)) + else if (charq .eq. 'R') then +c +c Repeats. set bits 5, 6, and/or 8 of islur(1,ip+1) +c +10 call getchar(lineq,iccount,durq) +c +c Save designator in case it's a terminal Rr or Rd +c + if (durq .eq. 'l') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),5) + go to 10 + else if (index('rdDbz',durq) .gt. 0) then + if (durq .eq. 'r') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),6) + else if (durq .eq. 'd') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),8) + else if (durq .eq. 'D') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),26) + else if (durq .eq. 'b') then + islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),25) + else if (durq .eq. 'z') then + iornq(1,nnl(1)+1) = ibset(iornq(1,nnl(1)+1),29) + end if + rptprev = .true. + rptfq1 = durq + go to 10 + end if + else if (charq .eq. 'V') then +c +c Ending +c + nnnl = nnl(1)+1 + lvoltxt = 0 +11 call getchar(lineq,iccount,durq) + if (durq.eq.'b' .or. durq .eq.'x') then +c +c End Volta, set bit9, and bit10 on if 'b' (end w/ box) +c + islur(1,nnnl) = ibset(islur(1,nnnl),9) + if (durq .eq. 'b') islur(1,nnnl) = ibset(islur(1,nnnl),10) + go to 11 + else if (durq .ne. ' ') then +c +c Start volta; Get text +c + if (lvoltxt .eq. 0) then +c +c First character for text +c + lvoltxt = 1 + islur(1,nnnl) = ibset(islur(1,nnnl),7) + nvolt = nvolt+1 + voltxtq(nvolt) = durq + else + voltxtq(nvolt) = voltxtq(nvolt)(1:lvoltxt)//durq + lvoltxt = lvoltxt+1 + end if + go to 11 + end if + else if (charq .eq. 'B') then + bcspec = .not.bcspec + else if (charq .eq. 'P') then +c +c Page numbers. Print stuff right now. +c + npg1 = 0 +c +c Will use ltopnam to signal whether there's a centered heading +c + ltopnam = 0 + ipg1r = 0 +16 call getchar(lineq,iccount,durq) + if (ichar(durq).ge.48 .and. ichar(durq).le.57) then + npg1 = npg1*10+ichar(durq)-48 + go to 16 + else if (durq .eq. 'l') then + if (npg1.eq.0 .or. mod(npg1,2).eq.1) ipg1r = 1 + go to 16 + else if (durq .eq. 'r') then + if (npg1.gt.0 .and. mod(npg1,2).eq.0) ipg1r = 1 + go to 16 + else if (durq .eq. 'c') then +c +c Top-centered name. Assume this is last option. Read the name. +c May surround name in double quotes (to allow blanks). +c + call getchar(lineq,iccount,durq) + if (durq .eq. ' ') then + ltopnam = lenstr(cheadq,60) + else + namstrt = iccount + if (durq .eq. '"') then +c +c Using quote delimiters. +c + quoted = .true. + namstrt = namstrt+1 + else + quoted = .false. + end if + do 35 iccount = namstrt+1, 128 + if ((quoted .and. lineq(iccount:iccount) .eq. '"') .or. + * (.not.quoted .and. lineq(iccount:iccount) .eq. ' ')) + * go to 36 +c +c On exit, iccount is OK, and name is in (namstrt:iccount-1) +c +35 continue + print*,'Awww, cmon, should not be here.' + call stop1() +36 continue + ltopnam = iccount-namstrt + cheadq = lineq(namstrt:iccount-1) + end if + end if +c +c Done getting data, now assemble the command +c + if (npg1.eq.0) npg1=1 +c +c 2/23/03 Don't use \atnextline if on first page and only one system +c +c if (ipage.gt.1 .or. nsystp(1).gt.1) then + hdlndq = sq//'def'//sq//'atnextline{'//sq//'toppageno{' + lhead = 27 +c else +c hdlndq = sq//'toppageno{' +c lhead = 11 +c end if + if (npg1 .lt. 10) then +c +c Note we are overwriting the last "{" +c + write(hdlndq(lhead:lhead),'(i1)')npg1 + else if (npg1 .lt. 100) then + lhead = lhead+3 + write(hdlndq(lhead-2:lhead),'(i2,a1)')npg1,'}' + else + lhead = lhead+4 + write(hdlndq(lhead-3:lhead),'(i3,a1)')npg1,'}' + end if + hdlndq = hdlndq(1:lhead)//chax(ipg1r+48)//'{' + lhead = lhead+2 +c if (ipage.gt.1 .or. nsystp(1).gt.1) then + if (ltopnam .eq. 0) then + if (islast) write(11,'(a)')hdlndq(1:lhead)//'}}%' + else + if (islast) + * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}}%' + end if +c else +c if (ltopnam .eq. 0) then +c if (islast) write(11,'(a)')hdlndq(1:lhead)//'}%' +c else +c if (islast) +c * write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}%' +c end if +c end if + else if (charq .eq. 'W') then +c +c Just eat the number that must follow, it was used in pmxa +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + else if (charq .eq. 'T') then + headlog = .true. + inhead = 0 + call getchar(lineq,iccount,durq) + if (durq .eq. 'i') then + call getbuf(instrq) +c +c A kluge for parts from separate score file for later movements. +c + if (instrq(1:1) .eq. ' ') headlog = .false. + cheadq = instrq + else if (durq .eq. 't') then + call getchar(lineq,iccount,durq) +c +c Optionally can include extra vertical \internotes above inbothd +c + if (index('-+0123456789',durq) .gt. 0) then + ipm = 1 + if (index('+-',durq) .gt. 0) then +c +c Don't trust readnum to round this negative integer properly +c + iccount = iccount+1 + if (durq .eq. '-') ipm = -1 + end if + call readnum(lineq,iccount,durq,fnum) + inhead = ipm*nint(fnum) + end if + call getbuf(titleq) + else + call getbuf(compoq) + end if + inhead = inhead+inbothd + iccount = 128 + else if (charq .eq. 'A') then +c +c Accidental handling etc. +c +27 call getchar(lineq,iccount,durq) + if (durq .eq. 'r') then + if (islast) then + relacc = .true. + write(11,'(a)')sq//'relativeaccid%' + end if + else if (durq .eq. 's') then + bacfac = 1.e6 + else if (durq .eq. 'b') then + if (islast) write(11,'(a)')sq//'bigaccid%' + accfac = bacfac + else if (durq .eq. 'a') then + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,fnum) + iccount = iccount-1 + else if (durq .eq. 'i') then + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,tintstf) + if (.not.firstgulp) fintstf = tintstf +c +c Local corrections for first page were handled by pmxa +c + iccount = iccount-1 + else if (durq .eq. 'I') then + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,gintstf) + iccount = iccount-1 + else if (durq .eq. 'd') then + lowdot = .true. + else if (durq .eq. 'o') then + continue + else if (durq .eq. 'S') then + do 50 iiv = 1 , nv + call getchar(lineq,iccount,durq) + if (index('-s',durq) .gt. 0) then + fullsize(iiv) = 0.8 + else if (durq .eq. 't') then + fullsize(iiv) = 0.64 + else + fullsize(ivx) = 1.0 + end if +50 continue + else if (durq .eq. 'e') then +c +c Line-spacing equalization +c + equalize = .true. +c +c The following redefinition of \parskip was put into pmx.tex in version 2.25 or so. +c But it causes problems with some older scores and when excerpts are combined +c with LaTeX. So as of 2.352 we write it here. +c + write(11,'(a)')sq//'global'//sq//'parskip 0pt plus 12'//sq + * //'Interligne minus 99'//sq//'Interligne%' + tempq = sepsymq(1) + lentemp = 1 + do 51 iiv = 2 , nv-1 + tempq = tempq(1:lentemp)//sepsymq(iiv) + lentemp = lentemp+1 +51 continue + write(11,'(a)')sq//'def'//sq//'upstrut{'//sq//'znotes' + * //tempq(1:lentemp)//sq//'zcharnote{'//sq//'upamt}{~}' + * //sq//'en}%' + else if (durq .eq. 'v') then +c +c Toggle usevshrink +c + usevshrink = .not.usevshrink + else if (durq .eq.'p') then +c +c Postscript slurs. fontslur is already false (set in g1etnote) +c + if (.not.WrotePsslurDefaults) then +c +c Set postscrirpt slur adjustment defaults +c + write(11,'(a)')sq//'Nosluradjust'//sq//'Notieadjust' + * //sq//'nohalfties' + WrotePsslurDefaults = .true. + end if +52 continue + call g1etchar(lineq,iccount,durq) ! might be "+", "-", "h" or "l" + if (index('+-',durq) .gt. 0) then +c +c Characters to change defaults for ps slurs +c + call g1etchar(lineq,iccount,charq) ! charq will be "s,t,h,c" + if (durq .eq. '+') then + if (charq .eq. 's') then + write(11,'(a)')sq//'Sluradjust' + else if (charq .eq. 't') then + write(11,'(a)')sq//'Tieadjust' + else if (charq .eq. 'h') then + write(11,'(a)')sq//'halfties' + else + SlurCurve = SlurCurve + 1 + if (SlurCurve .gt. 3.1) then + call printl('WARNING!') + call printl + * ('Default slur curvature advanced past HH, resetting') + SlurCurve = 3 + end if + end if + else + if (charq .eq. 's') then + write(11,'(a)')sq//'Nosluradjust' + else if (charq .eq. 't') then + write(11,'(a)')sq//'Notieadjust' + else if (charq .eq. 'h') then + write(11,'(a)')sq//'nohalfties' + else + SlurCurve = SlurCurve - 1 + if (SlurCurve .lt. -1.1) then + call printl('WARNING!') + call printl( + * 'Default slur curvature decremented below f, resetting') + SlurCurve = -1 + end if + end if + end if + go to 52 ! Check for another set of default changes + else if (durq .eq. 'l') then +c +c Set optional linebreak ties +c + OptLineBreakTies = .true. + go to 52 + else if (durq .eq. 'h') then +c +c Set flag to write header special on every page +c + HeaderSpecial = .true. + go to 52 + else + iccount = iccount-1 + end if + else if (durq .eq. 'K') then +c +c Toggle keyboard rest placement flag +c + kbdrests = .not.kbdrests + else if (durq .eq. 'c') then + call g1etchar(lineq,iccount,durq) +c +c Just eat the input; it was used in pmax +c + go to 27 + end if + if (index('NR',durq) .gt. 0) then +c +c Override default part names for scor2prt, or normal include file. +c Just bypass rest of input line +c + iccount = 128 + else if (durq .ne. ' ') then + go to 27 + end if + else if (charq .eq. 'K') then + call getchar(lineq,iccount,durq) + if (durq .ne. 'i') then +c +c Normal, full-score key change and/or transposition +c + num1 = 44-ichar(durq) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + num1 = num1*nint(fnum) +c +c On exit, durq='+','-'. But only need isig if after start, else done in pmxa +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + if (num1 .eq. 0) then +c +c Key change, not transposition. +c + ipl(ivx,nnl(ivx)+1) = ibset(ipl(ivx,nnl(ivx)+1),28) + lastisig = isig + isig = nint(fnum) + if (durq .eq. '-') isig = -isig + isig = isig+idsig + if (ismidi) call midievent('k',isig,0) + else +c +c num1 .ne. 0, so transposition, so must be at beginning. isig came with K... +c but was passed to pmxb through pmxtex.dat. isig0 comes from setup data +c (signature before transposition). idsig must be added to future key changes. +c + jv = 0 + do while (jv .lt. nm) + jv = jv+1 + iTransAmt(jv) = num1 + end do + idsig = isig-isig0 + end if + else +c +c Instrument specific transposition. + + call GetiTransInfo(.false.,ibarcnt,lineq,iccount, + * ibaroff,nbars,noinst,iv) + end if + else if (charq .eq. '/') then + if (btest(iornq(ivx,nnl(ivx)+1),26)) then +c +c There was a hardspace followed by end of block. Remove it from the hardspace +c list, store with shifts instead, set special bit. This code also at '|' +c + irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18) + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = udsp(nudsp) + nudsp = nudsp-1 + iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26) + end if + call getchar(lineq,iccount,durq) +c +c Save ending note level: +c + if (ivx .le. nv) then +c +c This is the first line of music on this staff. If previous block had only 1 +c voice, save last pitch from line 1 of prev. block to line 2, in case a +c 2nd line is started just below +c + if (.not.was2(iv)) ndlev(iv,2) = ndlev(iv,1) + was2(iv) = .false. + ndlev(iv,1) = lastlev + else +c +c This is the 2nd line of music on this staff. +c + was2(iv) = .true. + ndlev(iv,2) = lastlev + end if + if (durq .eq. ' ' .and. iv.eq.nv) then +c +c End of input block +c + loop = .false. + else +c +c Start a new line of music +c + if (lenb0.ne.0 .and. firstgulp) lenbar = lenb0 + nbars = 0 + if (durq .eq. ' ') then +c +c New line of music is on next staff +c + iv = iv+1 + ivx = iv + else +c +c durq must be 2nd '/'. New line of music is on same staff. Set up for it +c + ivx = nv+1 + do 23 iiv = 1 , nv + if (nvmx(iiv) .eq. 2) ivx = ivx+1 +23 continue + nvmx(iv) = 2 + ivmx(iv,2) = ivx + itsofar(ivx) = 0 + nnl(ivx) = 0 + nfb(ivx) = 0 + nudoff(ivx) = 0 + ndotmv(ivx) = 0 + do 24 j = 1 , 200 + irest(ivx,j) = 0 + islur(ivx,j) = 0 + nacc(ivx,j) = 0 + iornq(ivx,j) = 0 + ipl(ivx,j) = 0 + mult(ivx,j) = 0 +24 continue +c +c Go back and lower the rests in voice "a" that don't have over-ridden heights +c + do 26 j = 1 , nnl(iv) + if (btest(irest(iv,j),0) .and. nolev(iv,j).eq.0) + * nolev(iv,j) = -4 +26 continue + end if + end if + iccount = 128 + else if (charq .eq. 'X') then +c +c 3rd arg is only for termination of group shifts. Use "max" to avoid zero index, +c which only happens for normal X at block start, and we took special measures to +c keep group shifts for crossing block boundaries. +c + call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx))), + * shifton,wheadpt,iornq(ivx,nnl(ivx)+1),ivx, + * irest(ivx,nnl(ivx)+1),itsofar(ivx),0,0,0,' ',ndoub) + else if (charq .eq. 'I') then +c +c Midi controls. +c + call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, + * mtrdenl,.false.) + else if (charq .eq. 'M') then +c +c Macro action +c + call getchar(lineq,iccount,charq) + if (index('RS',charq) .gt. 0) then +c +c Record or save a macro. Get the number of the macro. +c + call getchar(lineq,iccount,durq) + call readnum(lineq,iccount,durq,fnum) + macnum = nint(fnum) + macuse = ibset(macuse,macnum) + if (charq .eq. 'R') then + call mrec1(lineq,iccount,ndxm) + else +c +c Save (Record but don't activate) +c +5 call mrec1(lineq,iccount,ndxm) + if (mrecord) then + call getbuf(lineq) + iccount = 0 + go to 5 + end if + iccount = iccount+ndxm+1 + end if + else if (charq .eq. 'P') then +c +c Playback the macro +c + call getchar(lineq,iccount,charq) + call readnum(lineq,iccount,durq,fnum) + macnum = nint(fnum) + icchold = iccount + lnholdq = lineq + iccount = 128 + ilmac = il1mac(macnum) + mplay = .true. + end if + else if (index(',.',charq) .gt. 0) then +c +c Continued rhythmic shortcut +c + idotform = index('. ,',charq) + if (idotform .eq. 1) then +c +c Check for start of forced beam on 2nd member of dotform=1 shortcut +c + if (fbon) then + if (t1fb(ivx,nfb(ivx)).eq.itsofar(ivx)) + * t1fb(ivx,nfb(ivx)) = + * t1fb(ivx,nfb(ivx))+nodur(ivx,nnl(ivx))/2 + end if +c +c Change duration of prior note +c + itsofar(ivx) = itsofar(ivx)-nodur(ivx,nnl(ivx)) + nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*3/2 + itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx)) + end if + idotform = idotform+1 + numnum = 1 + cdot = .true. + go to 1 + end if + return + end + subroutine getorn(lineq,iccount,iornq,iornq0,ornrpt,noffseg, + * ip,ivx,noxtup,notcrd,nole) +c +c iornq: Main note. Do not alter if chord note, except turn on bit 23 +c iornq0: Store iorni + bit 23, in case of repeated ornaments +c iorni: Internal use, 1st 21 bits of iornq or icrdorn, dep. on notcrd. +c noffseg: horiz. offset for segno +c nole: level of note w/ orn, used to ID the note/orn if there's a level shift. +c + + common /comivxudorn/ivxudorn(63) + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comcb/ nbc,ibcdata(36) + character*1 charq,durq + character*128 lineq + logical ornrpt,negseg,noxtup,notcrd +c +c Bits 0-13: (stmgx+Tupf._), 14: Down fermata, was F, 15: Trill w/o "tr", was U +c 16-18 Editorial sharp, flat, natural "oes,f,n"; 19-20: >^, 21 TBD +c + call getchar(lineq,iccount,charq) + if (index('bc',charq) .gt. 0) then +c +c caesura or breath, handle specially and exit. Set up data in ibcdata(1...nbc) +c ivx(0-3,28), ip(4-12), +c vshift (vshift+32 in bits 13-18), +c hshift (nint(10*vshift)+128 in bits 19-26) +c bit 27 = 0 if caesura, 1 if breath +c bit 28: 5th bit of ivx +c + iornq = ibset(iornq,28) + nbc = nbc+1 +c ibcdata(nbc) = ivx+16*ip + ibcdata(nbc) = mod(ivx,16)+16*ip + if (ivx.ge.16) ibcdata(nbc) = ibset(ibcdata(nbc),28) + if (charq .eq. 'b') ibcdata(nbc) = ibset(ibcdata(nbc),27) + call getchar(lineq,iccount,durq) + if (index('+-',durq) .gt. 0) then +c +c We have a vertical shift, get it +c + iccount = iccount+1 + call readnum(lineq,iccount,charq,fnum) + if (durq .eq. '-') fnum=-fnum + call setbits(ibcdata(nbc),6,13,nint(32+fnum)) + if (index('+-',charq) .gt. 0) then +c +c Horizontal shift, get it +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (charq .eq. '-') fnum=-fnum + call setbits(ibcdata(nbc),8,19,nint(10*fnum)+128) + end if + end if + return + end if +c +c Set signal on main note that some note at this time has ornament. ONLY used +c in beamstrt to activate further tests for whether ihornb is needed. +c + iornq = ibset(iornq,23) +c +c Isolate 21 bits defining exisiting ornaments +c + if (notcrd) then + iorni = iand(4194303,iornq) + else + iorni = iand(4194303,icrdorn(ncrd)) + end if + korn = index('stmgx+Tupf._)e:XXX>^',charq) + if (korn .ne. 15) iorni = ibset(iorni,korn) +c +c Note that korn=0 => charq='(', and we set bit 0. if "e" (14), alter later +c as follows: korn=16-18 for sfn, and or 21 for bare ?. +c When this if-block is done, korn will = bit# of actual ornament (unless "?"). +c + if (korn .eq. 15) then +c +cc Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-20 prev iornq +c Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21 prev iornq +c +c iorni = ior(iorni,iand(iornq0,1638383)) + iorni = ior(iorni,iand(iornq0,3735535)) + ornrpt = .false. + call getchar(lineq,iccount,durq) +c +c durq will be ' ' +c + else if (korn .eq. 14) then +c +c Editorial accidental +c + call getchar(lineq,iccount,durq) +c korn = 15+index('sfn',durq) + korn = 15+index('sfn?',durq) + if (korn .eq. 19) korn=21 + iorni = ibset(ibclr(iorni,14),korn) + call getchar(lineq,iccount,durq) + if (durq .eq. '?') then +c +c This is "oe[s|f|n]?". Set 21st bit also. +c + iorni = ibset(iorni,21) + korn = korn+6 + call getchar(lineq,iccount,durq) + end if +c iorni = ibset(ibclr(iorni,14),korn) + else if (korn.eq.4 .and. noxtup) then +c +c segno. Check in pmxa for just 1/block & notcrd. Get horiz. offset in points +c + noffseg = 0 + negseg = .false. + call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then +c +c Segno shift is specified +c + if (durq .eq. '-') then + negseg = .true. + call getchar(lineq,iccount,durq) + end if + call readnum(lineq,iccount,durq,fnum) + noffseg = int(fnum) + if (negseg) noffseg = -noffseg + end if + else if (korn .eq. 7) then +c +c Trill. Check in pmxa for notcrd. Default is 1 noteskip long, with "tr" +c + ntrill = ntrill + 1 + ivtrill(ntrill) = ivx + iptrill(ntrill) = ip + xnsktr(ntrill) = 1. + call getchar(lineq,iccount,durq) + if (durq .eq. 't') then +c +c Convert to new internal symbol for non-'"tr" trill +c + korn = 15 + iorni = ibset(ibclr(iorni,7),15) + call getchar(lineq,iccount,durq) + end if + if (index('0123456789.',durq) .gt. 0) then +c +c We have a number for the length +c + call readnum(lineq,iccount,durq,xnsktr(ntrill)) + end if + else if (korn.eq.10 .and. noxtup) then +c +c Fermata +c + call getchar(lineq,iccount,durq) + if (durq .eq. 'd') then + korn = 14 + iorni = ibset(ibclr(iorni,10),14) + call getchar(lineq,iccount,durq) + end if + else + call getchar(lineq,iccount,durq) + end if + if (index('+- :',durq) .eq. 0) then + print*,'Unexpected character at end of ornament: ',durq + call stop1() + end if + if (index('+-',durq) .gt. 0) then +c +c Shift ornament up or down +c + nudorn = nudorn+1 +c +c Set bit 25 in iorni as a signal. This may not really be necessary. +c + iorni = ibset(iorni,25) +c +c Assemble info to put in kudorn(nudorn) Bits 0-7:ip, 8-11:ivx, 12-18:nolev, +c 19-24: type of ornament to be shifted, 25-30: shift+32, 31:h-shft present +c + xofforn = 44-ichar(durq) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + iofforn = nint(xofforn*fnum) + kudorn(nudorn) = ip+ishft(mod(ivx,16),8)+ishft(nole,12) + * +ishft(korn,19)+ishft(iofforn+32,25) + ivxudorn(nudorn) = ivx + if (index('+-',durq) .gt. 0) then +c +c Horizontal shift +c + kudorn(nudorn) = ibset(kudorn(nudorn),31) + xofforn = 44-ichar(durq) + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + ornhshft(nudorn) = nint(xofforn*fnum) + end if + else if (durq .eq. ':') then +c +c Turn on repeated ornaments +c + ornrpt = .true. +c +c Save the ornament value just set +c + iornq0 = iorni + end if + if (notcrd) then + iornq = ior(iornq,iorni) + else + icrdorn(ncrd) = ior(icrdorn(ncrd),iorni) + end if + return + end + subroutine getpmxmod(global,includeq) +c +c If global=.true., checks for environment variable with path to pmx.mod. +c Then, if variable exists and points to pmx.mod, insert lines from +c pmx.mod into buffer +c If global=.false., checks for existence of includeq and uses it. +c +c lenbuf0 = total length of bufq on entry +c lbuf(i) = length of line (i) +c nlbuf = number of lines stored in bufq +c ilbuf = index of first line after setup stuff (on entry). In general, index of +c next line to be sucked from buffer. +c ilbufmod = counter for lines in pmx.mod as they are grabbed. +c Starts at ilbuf. Points to position of next line after +c pmx.mod stuff in bufq on exiting loop 1 +c ilbuff = transient counter for shifting operations +c ipbuf = on entry, points to last character in setup stuff. In general, points +c to last character of most recent line sucked from buffer. +c ipbufmod = points to last character of most recent inserted line +c from pmx.mod +c + parameter (maxblks=4000,nm=24) + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,fbon,issegno,isheadr,isvolt + character*(*)includeq + character*80 pmxmoddirq + character*128 lnholdq + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + logical fexist,global + line1pmxmod = ilbuf + if (.not.global) then + inquire(file=includeq,EXIST=fexist) +c +c Transfer includeq to temporary char variable with known length +c + pmxmoddirq = includeq + lpmxmoddirq = lenstr(pmxmoddirq,80) + print* + write(15,'()') + if (.not.fexist) then + call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq) + * //', checking further.') +c +c File named includeq doesn't not exist. Get directory from PMXMODDIR and +c see if it's there +c + call getenv('PMXMODDIR',pmxmoddirq) + lpmxmoddirq = lenstr(pmxmoddirq,80) + if (lpmxmoddirq. gt. 0) then + pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//includeq + lpmxmoddirq = lenstr(pmxmoddirq,80) + else + call printl( + * 'No other directory defined by PMXMODDIR, stopping') + call stop1() + end if + inquire(file=pmxmoddirq,EXIST=fexist) + if (.not.fexist) then + call printl('Could not find '//pmxmoddirq(1:lpmxmoddirq) + * //', stopping.') + call stop1() + end if + end if + call printl('Opening normal include file ' + * //pmxmoddirq(1:lpmxmoddirq)) + open(18,file=pmxmoddirq) + else +c +c Check for existence of pmx.mod +c + call getenv('PMXMODDIR',pmxmoddirq) + lpmxmoddirq = lenstr(pmxmoddirq,80) + if (lpmxmoddirq .eq. 0) return + pmxmoddirq = pmxmoddirq(1:lpmxmoddirq)//'pmx.mod' + lpmxmoddirq = lpmxmoddirq+7 + inquire(file=pmxmoddirq,EXIST=fexist) + if (.not.fexist) return + call printl('Opening global include file ' + * //pmxmoddirq(1:lpmxmoddirq)) + open(18,file=pmxmoddirq(1:lpmxmoddirq)) + end if + call printl('Adding include data') +c +c Read lines in from pmx.mod one at a time +c + ipbufmod = ipbuf + lenbufmod = lenbuf0 + do 1 ilbufmod = ilbuf , maxblks + read(18,'(a)',end=3)lnholdq +c +c A line was read. Slide all existing lengths from here forward ahead by 1 +c + do 2 ilbuff = nlbuf , ilbufmod , -1 + lbuf(ilbuff+1) = lbuf(ilbuff) +2 continue +c +c Get length of line from include file +c + lenmodline = lenstr(lnholdq,128) + if (lenmodline .eq. 0) then +c +c Blank line. Make it a single blank with length 1 +c + lenmodline = 1 + lnholdq = ' ' + end if + lbuf(ilbufmod) = lenmodline + call printl(lnholdq(1:lenmodline)) +c +c Insert new stuff into bufq +c + bufq = bufq(1:ipbufmod)//lnholdq(1:lenmodline)// + * bufq(ipbufmod+1:lenbufmod) +c +c Update internal parameters +c + ipbufmod = ipbufmod+lbuf(ilbufmod) + lenbufmod = lenbufmod+lbuf(ilbufmod) + nlbuf = nlbuf+1 +1 continue +3 continue + call printl('Closing '//pmxmoddirq(1:lpmxmoddirq)) + close(18) + linesinpmxmod = linesinpmxmod+ilbufmod-ilbuf + lenbuf0 = lenbufmod +c +c Fix Andre's error reporting problem 101211 leading to log(neg#) due +c to nline being 2 bigger than it should be +c + nline=nline-2 +c + return + end + subroutine getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, + * xmtrnum0,npages,nsyst,musicsize,fracindent,istype0, + * inameq,clefq,sepsymq,pathnameq,lpath,isig0) + parameter (nm=24) + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + character*1 clefq(nm),sepsymq(nm) + character*40 pathnameq + character*79 inameq(nm) + character*128 lineq + logical istype0,newway,rename +c +c Get the first line +c + iccount = 0 +9 call getbuf(lineq) + if (lineq(1:1) .eq. '%') go to 9 + istype0 = lineq(1:3).eq.'---' + if (istype0) then +c +c Have TeX input until next line that starts with '---'. Save in scratch. +c + open(17,status='SCRATCH') +3 call getbuf(lineq) + if (lineq(1:3) .ne. '---') then + write(17,'(a)')lineq + go to 3 + end if +c +c Force a new line read on first call to readin +c + iccount = 128 + end if +c +c Here, lineq is first line w/ numerical setup data. +c + nv = nint(readin(lineq,iccount,nline)) + noinst = nint(readin(lineq,iccount,nline)) + newway = noinst.le.0 + if (newway) noinst = -noinst + do 2 iinst = 1 , noinst +c +c Seve # of staves per inst in case later drop some inst's. +c + if (newway) then +c +c Read in nvi for each instrument +c + nsperi(iinst) = nint(readin(lineq,iccount,nline)) + else if (iinst .gt. 1 ) then + nsperi(iinst) = 1 + else + nsperi(iinst) = nv-noinst+1 + end if + iiorig(iinst) = iinst + nspern(iinst) = nsperi(iinst) +2 continue + mtrnuml = nint(readin(lineq,iccount,nline)) + mtrdenl = nint(readin(lineq,iccount,nline)) +cc +cc Kluge to make mtrdenl work +cc +c if (mtrdenl .eq. 1) then +c mtrdenl = 2 +c mtrnuml = mtrnuml*2 +c end if + mtrnmp = nint(readin(lineq,iccount,nline)) + mtrdnp = nint(readin(lineq,iccount,nline)) + xmtrnum0 = readin(lineq,iccount,nline) +c +c Original key sig (before any trnasposition) in next position. Transposed +c sig for topfile was transferred thru pmxtex.dat. Need isig0 for key +c changes if transposed. +c + isig0 = nint(readin(lineq,iccount,nline)) + npages = nint(readin(lineq,iccount,nline)) + nsyst = nint(readin(lineq,iccount,nline)) + musicsize = nint(readin(lineq,iccount,nline)) + fracindent = readin(lineq,iccount,nline) +c +c Next noinst non-comment lines are names of instruments. +c + do 4 i = 1 , noinst +5 call getbuf(inameq(i)) + if (inameq(i)(1:1) .eq. '%') go to 5 +4 continue +c +c Mext non-comment line has nv clef names +c +6 call getbuf(lineq) + if (lineq(1:1) .eq. '%') go to 6 + iv = 0 + nvsofar = 0 + do 1 jinst = 1 , noinst + nvsofar = nvsofar+nsperi(jinst) + do 10 ivi = 1 , nsperi(jinst) + iv = iv+1 + clefq(iv) = lineq(iv:iv) + if (iv .eq. nvsofar) then + sepsymq(iv) = '&' + else + sepsymq(iv) = '|' + end if +10 continue +1 continue +c +c Mext non-comment line has path name +c +8 call getbuf(pathnameq) + if (pathnameq(1:1) .eq. '%') go to 8 + lpath = index(pathnameq,' ')-1 + return + end + function getsquez(n,ntot,space,tnote,to) + real*4 tnote(600),to(600) + common /comtol/ tol +c +c Get the squez factor by checking space against tgovern=minimum duration +c of all notes sounding at time of n-th note in the list. +c The starting time of base increment is to(n) and ending time is to(n)+space +c Sounding notes are those that start at or before to(n) .and. end at or +c after tend=to(n)+space +c Since notes are ordered by increasing start times, as soon as we find one +c that starts too late, we are done checking. +c + tgovern = 1000. + tend = to(n)+space + do 1 in = 1 , ntot +c +c Since to() is ordered by start times, exit loop after first note that +c starts later than note of interest. +c + + if (to(in) .gt. to(n)+tol) go to 2 + if (to(in)+tnote(in) .gt. tend-tol) then +c +c If here, this note overlaps and must be tested. +c + tgovern = min(tgovern,tnote(in)) + end if +1 continue +2 continue + getsquez = space/tgovern + return + end + subroutine getx(lineq,iccount,irest,shifton,wheadpt,iornq1,ivx, + * irest1,itsofar,ntup,itup,nnodur,dotq,ndoub) + parameter(nm=24) +c +c Parse "X" commands. Ignore all "B"; "P" means to ignore whole symbol. +c In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols. +c Since during getnote phase time is integer itsofar, which is not updated +c during xtups, we use itup and ntup to get actual time. On entry, ntup=0 if +c not in xtup. +c + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + logical shifton,colon,ess,number + character*128 lineq + character*1 charq,durq,dotq + colon = .false. + ess = .false. + number = .false. + nextbl = iccount+index(lineq(iccount:128),' ')-1 + if (index(lineq(iccount:nextbl),'P') .gt. 0) then +c +c "Parts only", ignore entire symbol +c + iccount = nextbl + return + end if +1 call getchar(lineq,iccount,charq) + if (charq.eq.'B') then +c +c "Both parts and score," ignore character +c + go to 1 + else if (charq .eq. ':') then + colon = .true. + go to 1 + else if (charq .eq. 'S') then + ess = .true. + go to 1 + else if (index('+-.0123456789',charq) .gt. 0) then + number = .true. + if (charq.eq.'-') iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (charq .eq. '-') fnum = -fnum + if (durq .ne. 'p') then + fnum = fnum*wheadpt + iccount = iccount-1 + end if + go to 1 + end if +c +c charq must be blank, so done parsing +c + if (.not.ess .and. .not.colon) then +c +c Ordinary hardspace. Goes before next note. +c (Later, at "|" or "/", check for presence and switch to udoff if there!) +c + nudsp = nudsp+1 + iornq1 = ibset(iornq1,26) + udsp(nudsp) = fnum + tudsp(nudsp) = itsofar + if (ntup .gt. 0) tudsp(nudsp) = tudsp(nudsp) +c * +float(itup-1)/ntup*ifnodur(nnodur,dotq) + * +float(itup-1+ndoub)/ntup*ifnodur(nnodur,dotq) + else if (.not.number) then +c +c Must be "X:" End a group offset. +c + irest = ibset(irest,17) + shifton = .false. + return + else +c +c Only other possibility is start offset, "S" for single, ':' for multiple +c + nudoff(ivx) = nudoff(ivx)+1 + udoff(ivx,nudoff(ivx)) = fnum + if (ess) then + irest1 = ibset(irest1,15) + else + irest1 = ibset(irest1,16) + shifton = .true. + end if + end if + return + end + function i1fnodur(idur,dotq) + character*1 dotq + if (idur .eq. 6) then + i1fnodur=1 + else if (idur .eq. 3) then + i1fnodur=2 + else if (idur .eq. 1) then + i1fnodur=4 + else if (idur .eq. 8) then + i1fnodur=8 + else if (idur .eq. 4) then + i1fnodur=16 + else if (idur .eq. 2) then + i1fnodur=32 + else if (idur .eq. 0) then + i1fnodur=64 + else if (idur .eq. 16) then +c +c Only used for denominator of time signatures, not for notes +c + i1fnodur=4 + else if (idur .eq. 9) then + i1fnodur = 128 + else + print* + print*,'You entered an invalid note-length value:',idur + call stop1() + end if + if (dotq .eq. 'd') i1fnodur = i1fnodur*3/2 + return + end +c integer*4 function longi(ishort) +c integer*2 ishort +c longi = ishort +c return +c end + function iashft(nacc) + integer*4 ias(6) + data ias /-1,1,0,0,-2,2/ + iashft = ias(nacc) + return + end + function ifnodur(idur,dotq) + character*1 dotq + if (idur .eq. 6) then + ifnodur=1 + else if (idur .eq. 3)then + ifnodur=2 + else if(idur .eq. 1) then + ifnodur=4 + else if(idur .eq. 8) then + ifnodur=8 + else if(idur .eq. 4) then + ifnodur=16 + else if(idur .eq. 2) then + ifnodur=32 + else if(idur .eq. 0) then + ifnodur=64 + else if(idur .eq. 9) then + ifnodur=128 + else if (idur .eq. 16) then +c +c Only used for denominator of time signatures, not for notes +c + ifnodur=4 + else + print*,'You entered an invalid note value' + stop + end if + if (dotq .eq. 'd') ifnodur = ifnodur*3/2 + return + end + function ifnolev(noq,oct,ntrans) + character*1 noq + integer oct + ifnolev = 7*oct+mod(ichar(noq)-92,7)+1+ntrans + return + end +c subroutine report(nsdat,isdat1,isdat2) +c integer*4 isdat1(202),isdat2(202) +c write(*,'(a)') +c * ' isd on? iv kv ip id ud1 ud2 ndx ivo iho lev crd lhd rhd' +c do 1 isdat = 1 , nsdat +c isdata = isdat1(isdat) +c ionoff = igetbits(isdata,1,11) +cc iv = iand(7,isdata) +c iv = igetbits(isdata,5,13) +c kv = igetbits(isdata,1,12)+1 +c ip = igetbits(isdata,8,3) +c idcode = igetbits(isdata,7,19) +c iud1 = igetbits(isdata,1,26) +c iud2 = igetbits(isdata,1,27) +c ndxslur = igetbits(isdata,4,28) +c isdatb = isdat2(isdat) +c ivo = igetbits(isdatb,6,6)-32 +c iho = igetbits(isdatb,7,12)-64 +c lev = igetbits(isdatb,7,19) +c icrd = igetbits(isdatb,1,0) +c lhd = igetbits(isdatb,1,1) +c irhd = igetbits(isdatb,7,2) +c write(*,'(17i4)')isdat,ionoff,iv,kv,ip,idcode,iud1,iud2,ndxslur, +c * ivo,iho,lev,icrd,lhd,irhd +c1 continue +c print* +c return +c end + function igetbits(isdata,iwidbit,ishift) +c +c Extracts integer given by iwidbit bits of isdata, shifted by ishift, and +c then added to ioff +c + igetbits = iand(2**iwidbit-1,ishft(isdata,-ishift)) + return + end + function igetvarlen(mmidi,icm,imidi,nbytes) +c +c Gets variable-length integer starting in mmidi at imidi+1. Returns nbytes. +c + parameter (nm=24,mv=24576) + integer*2 mmidi(0:nm,mv) + igetvarlen = 0 + do 1 nbytes = 1 , 4 + igetvarlen = 128*igetvarlen + * +iand(127,mmidi(icm,imidi+nbytes)) +c * +iand(127,longi(mmidi(icm,imidi+nbytes))) + if (.not.btest(mmidi(icm,imidi+nbytes),7)) return +c if (.not.btest(longi(mmidi(icm,imidi+nbytes)),7)) return +1 continue + print*,'Messup in igetvarlen' + call stop1() + end + logical function isdotted(nodur,ivx,ip) + parameter (nm=24) +c +c Function returns true if note is dotted or double-dotted. +c Return false for any xtuplet. +c + common /comtol/ tol + integer*4 nodur(nm,200) + if (nodur(ivx,ip) .eq. 0) then + isdotted = .false. + return + else if (ip .gt. 1) then + if (nodur(ivx,ip-1) .eq. 0) then + isdotted = .false. + return + end if + end if +c +c Ruled out all xtups, so is dotted or double-dotted if not a power of 2. +c + isdotted = + * mod(alog(float(nodur(ivx,ip)))/.69314718+.5*tol,1.) .gt. tol + return + end + function isetvarlen(idur,nbytes) + isetvarlen = 0 + itemp = idur + do 1 nbytes = 1 , 4 + isetvarlen = isetvarlen + iand(itemp,127)*256**(nbytes-1) + itemp = ishft(itemp,-7) + if (itemp .gt. 0) then + isetvarlen = isetvarlen+2**(8*nbytes+7) + else + return + end if +1 continue + print*,'Problem in function isetvarlen' + call stop1() + end + subroutine istring(i,string,len) +c +c Returns string with integer only if length is 1, otherwise enclosed in +c brackets. +c + character*(*) string + if (i .ne. 0) then + len = alog10(abs(i)*1.0001)+1 + if (i .lt. 0) len = len+1 + else + string = '0' + len = 1 + return + end if + if (len .eq. 1) then + string = char(48+i) + else + string = '{' + write(string(2:1+len),'(i'//char(48+len)//')')i + string = string(1:len+1)//'}' + len = len+2 + end if + return + end + function lenstr(string,n) + character*(*) string + do 1 lenstr = n , 1 , -1 + if (string(lenstr:lenstr) .ne. ' ') return +1 continue + lenstr = 0 + return + end + function levrn(nolev,irest,iud,ncm,mult) +c +c Used for placing numbers in xtups. Returns note level if not a rest, +c else level of top or bottom of rest symbol opposite beam. iud=-1 for upstm. +c + logical btest + if (.not.btest(irest,0)) then + levrn = nolev + else +c +c Restlevel is -4, 0, 2 or 100+offset. First get offset from 1-voice default. +c + if (mult .gt. 0) then + if (mult .eq. 2) then + ioff = -1+2*iud + else if (mult .ne. 4) then + ioff = iud*mult + else + ioff = 1+4*iud + end if + else +c +c May need to futz with this later for non-beamed xtups (quarter, half rests) +c + ioff = iud*2 + end if + levrn = mod(nolev+20,100)-20+ncm+ioff + endif + return + end + function lfmt1(x) +c +c Computes total length of an "f" format with one decimal place. +c First round to nearest 0.1 +c + if (abs(x) .lt. .001) then + lfmt1 = 2 + else + y = sign(.1*int(10*abs(x)+.5),x) + lfmt1 = int(log10(1000*abs(y)+.001)) + if (y .lt. 0) lfmt1 = lfmt1+1 + end if + return + end + subroutine LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat, + * ispstie,sepsymq) + parameter (nm=24) + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comoct/ noctup + integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) + logical fontslur,WrotePsslurDefaults,btest,upslur,ispstie,tie + character*1 udq,chax,sepsymq(nm) + character*8 noteq + character*128 notexq +c +c This is called twice from pmxb after having input an entire block, before +c making a bar that starts a new system. So nsdat reflects all slur starts +c and stops in new block, while listslur, which is only set when bars are +c made, reflects only open slurs from the old block. So we must check +c listslur to find open ties, not all nsdat. +c First of two calls (ispstie=.false. on entry) terminates tie at end of line. +c Second (ispstie=.true. on entry) restarts tie at start of new line. Only +c need data from original tie-start for both of these. Tie/slur data from +c closing of full tie are not used except for shape alterations. +c +c do 1 ndx = 0 , 11 + do 1 ndx = 0 , 23 + if (btest(listslur,ndx)) then +c +c Slur or tie with index ndx is open. Find the one with right ndxb, see if tie +c + do 2 isdat = 1 , nsdat +c if (igetbits(isdat1(isdat),4,28) .ne. ndx) go to 2 ! Wrong index + if (igetbits(isdat1(isdat),4,28) + * +16*igetbits(isdat1(isdat),1,18) .ne. ndx) go to 2 ! Wrong index + if (.not.btest(isdat1(isdat),11)) go to 2 ! Bypass if stop + if (btest(isdat2(isdat),3)) go to 3 ! "st" + idcode = igetbits(isdat1(isdat),7,19) + if (idcode.eq.1) go to 3 ! "t" + tie = .false. + go to 5 +2 continue + end if + go to 1 +3 continue + tie = .true. +5 continue +c +c A slur or tie is open, with index ndx +c + iv = igetbits(isdat1(isdat),5,13) + kv = igetbits(isdat1(isdat),1,12)+1 + udq = 'd' + if (btest(isdat1(isdat),27)) udq='u' + notexq = chax(92)//'znotes' + lnote = 7 + do 4 iiv = 1 , iv-1 + notexq = notexq(1:lnote)//sepsymq(iiv) + lnote = lnote+1 +4 continue + if (kv .eq. 2) then + notexq = notexq(1:lnote)//chax(92)//'nextvoice' + lnote = lnote+10 + end if +c +c Compute horiz and vert offsets +c +c nolev = igetbits(isdat2(isdat),7,19) + islhgt = igetbits(isdat3(isdat),8,14) + ilb12 = 0 + if (ispstie) ilb12 = 1 + ivoff = igetbits(isdat4(isdat),6,ilb12*16)-32 + if (ivoff .eq. -32) ivoff = 0 +C nolev = nolev+ivoff + islhgt = islhgt+ivoff + ihoff = (igetbits(isdat4(isdat),7,ilb12*16+6)-64) ! This is 10X hoff + if (ihoff .eq. -64) ihoff = 0 +c +c Add starting stuff for command +c + if (.not.ispstie) then ! End 1st segment + notexq = notexq(1:lnote)//chax(92)//'roffset{' + lnote = lnote+9 +c hoff = ihoff*.1-.5 +c hoff = ihoff*.1-.8 + hoff = ihoff*.1-.4 + if (hoff .lt. 0) then + hoff = -hoff + notexq = notexq(1:lnote)//'-' + lnote = lnote+1 + end if + call writflot(hoff,notexq,lnote) + notexq = notexq(1:lnote)//'}{' + lnote = lnote+2 + else + notexq = notexq(1:lnote)//chax(92)//'off{-' + * //chax(92)//'afterruleskip}' + lnote = lnote+21 +c +c 091025 add dotting for 2nd segment if needed +c + if (btest(isdat2(isdat),4)) then + notexq = chax(92)//'dotted'//notexq(1:lnote) + lnote = lnote+7 + end if + end if + if (ispstie .and. tie) then + notexq = notexq(1:lnote)//chax(92)//'tieforis'//udq + lnote = lnote+10 + end if + if (btest(isdat3(isdat),0)) then +c +c Curvature tweak on termination of 1st seg +c + imid = igetbits(isdat3(isdat),6,2)-32 +c +c Invoke macro (from pmx.tex) that redefines \tslur as r'qd. mapping: +c Abs(imid) Postscript slur type +c 1 f +c 4 h +c 5 H +c 6 HH +c + notexq = notexq(1:lnote)//chax(92)//'psforts'//chax(48+imid) + lnote = lnote+9 +c +c Zero out the flag in case there's a different curv on term of 2nd, +c + isdat3(isdat) = ibclr(isdat3(isdat),0) + end if +c +c Add the command name +c + if (ispstie) then + notexq = notexq(1:lnote)//chax(92)//'is'//udq + lnote = lnote+4 + else if (tie) then + notexq = notexq(1:lnote)//chax(92)//'ttie' + lnote = lnote+5 + else + notexq = notexq(1:lnote)//chax(92)//'tslur' + lnote = lnote+6 + end if +c +c Add index +c +c if (11-ndx .lt. 10) then +c notexq = notexq(1:lnote)//chax(59-ndx) +c lnote = lnote+1 +c else +c notexq = notexq(1:lnote)//'{1'//chax(49-ndx)//'}' +c lnote = lnote+4 +c end if + if (23-ndx .lt. 10) then + notexq = notexq(1:lnote)//chax(71-ndx) + lnote = lnote+1 + else if (23-ndx .lt. 20) then + notexq = notexq(1:lnote)//'{1'//chax(61-ndx)//'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//'{2'//chax(51-ndx)//'}' + lnote = lnote+4 + end if + if (ispstie .or. .not.tie) then +c +c Add note name for slur height +c + noctup = 0 + ncm = igetbits(isdat3(isdat),8,22) + if (ncm .eq. 23) noctup = -2 +c call notefq(noteq,lnoten,nolev,ncm) + call notefq(noteq,lnoten,islhgt,ncm) + notexq = notexq(1:lnote)//'{'//noteq(1:lnoten)//'}' + lnote = lnote+1+lnoten+1 + end if + if (ispstie) then +c +c Horizontal shift start of new thing +c + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 +c ihoff = ihoff-13 + if (tie) then + ihoff = ihoff-12 + else + ihoff = ihoff-7 + end if + if (ihoff .lt. 0) then + ihoff = -ihoff + notexq = notexq(1:lnote)//'-' + lnote = lnote+1 + end if + call writflot(ihoff*.1,notexq,lnote) + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if +c +c Add closing stuff +c + if (ispstie) then + notexq = notexq(1:lnote)//chax(92)//'off{' + * //chax(92)//'afterruleskip}' + lnote = lnote+20 + else + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + notexq = notexq(1:lnote)//chax(92)//'en%' + lnote = lnote+4 + write(11,'(a)')notexq(1:lnote) +1 continue + ispstie = .not.ispstie + return + end + subroutine littex(islur,nnl,iv,topmods,lineq,iccount) + parameter (nm=24) + common /comlast/ islast,usevshrink + logical islast,usevshrink + integer islur(nm,200) + logical topmods + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,merge + character*128 lineq,litq + character*20 voltxtq + character*1 durq,chax + merge = .false. + if (nlit .gt. 0) then + merge = iv.eq.ivlit(nlit) .and. nnl.eq.iplit(nlit) + end if + nlit = nlit+1 + ivlit(nlit) = iv + iplit(nlit) = nnl + itype = 1 +17 call getchar(lineq,iccount,durq) + if (durq .eq. chax(92)) then + itype=itype+1 + go to 17 + end if + litq(nlit) = chax(92)//durq + lenlit(nlit) = 2 +18 call getchar(lineq,iccount,durq) + if (durq.eq.chax(92)) then + call getchar(lineq,iccount,durq) + if (durq .ne. ' ') then +c +c Starting a new tex command within the string +c + litq(nlit) = litq(nlit)(1:lenlit(nlit))//chax(92)//durq + lenlit(nlit) = lenlit(nlit)+2 + go to 18 + end if + else + litq(nlit) = litq(nlit)(1:lenlit(nlit))//durq + lenlit(nlit) = lenlit(nlit)+1 + go to 18 + end if +c +c If here, just read backslash-blank so string is done +c + if (itype .eq. 1) then + islur(iv,nnl) = ibset(islur(iv,nnl),16) + if (merge) then +c +c There are 2 separate strings on the same note, so merge them. +c + nlit = nlit-1 + litq(nlit) = litq(nlit)(1:lenlit(nlit)) + * //litq(nlit+1)(1:lenlit(nlit+1)) + lenlit(nlit) = lenlit(nlit)+lenlit(nlit+1) + if (lenlit(nlit) .gt. 128) then + print* + print*, + * 'Merged type-1 TeX strings longer than 128 characters' + write(15,'(/,a)') + * 'Merged type-1 TeX strings longer than 128 characters' + call stop1() + end if + end if + else + if (itype .eq. 3) then +c +c Write the string NOW +c + if (islast) + * write(11,'(a)')litq(nlit)(1:lenlit(nlit))//'%' + else +c +c Must go at top +c + if (.not.topmods) then + topmods = .true. + open(16,status='SCRATCH') + end if +c +c Must write '%' here rather than later, in case string ends with blank. +c + write(16,'(a)')litq(nlit)(1:lenlit(nlit))//'%' + end if + nlit = nlit-1 + end if + return + end + function llen(strq,n) + character*129 strq + do 1 llen = n , 0 , -1 + if (strq(llen:llen) .ne. ' ') return +1 continue + end + function log2(n) +c +c 5/25/08 Modify to allow more slurs +c +c log2 = alog(1.*n)/0.6931472+.0001 +c log2 = dlog(1.d0*n)/0.693147181d0+.00000001d0 + log2 = dlog(1.d0*n)/0.693147181d0+.00000002d0 + return + end + subroutine logbeam(numnew,nip1,nip2) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*1 ulq,sepsymq,sq,ulfq,ulfbq + logical beamon,firstgulp,figbass,figchk,isfig,isxtup,btest, + * autofbon + ibm1(ivx,numnew) = nip1 + ibm2(ivx,numnew) = nip2 + numnow = numnew + if (numnew .gt. 1) then +c +c If it starts before any others, must put it in order +c + do 11 ib = numnew-1 , 1 , -1 + if (ibm1(ivx,ib) .lt. nip1) go to 12 + ibm1(ivx,ib+1) = ibm1(ivx,ib) + ibm2(ivx,ib+1) = ibm2(ivx,ib) + ulq(ivx,ib+1) = ulq(ivx,ib) + ibm1(ivx,ib) = nip1 + ibm2(ivx,ib) = nip2 + numnow = ib +11 continue +12 continue + end if + sum = 0. +c +c Beam has non-xtup within +c + nrests = 0 + isxtup = .false. + do 9 iip = nip1 , nip2 + if (btest(islur(ivx,nip1),21)) then +c +c Forced multiplicity +c +c mult(ivx,iip) = igetbits(islur(ivx,nip1),3,22) + call setbits(mult(ivx,iip),4,0, + * igetbits(islur(ivx,nip1),3,22)+8) + else if (.not.isxtup) then + if (nodur(ivx,iip) .gt. 0) then +c mult(ivx,iip) = 4-log2(nodur(ivx,iip)) + call setbits(mult(ivx,iip),4,0,4-log2(nodur(ivx,iip))+8) + else +c +c Start xtup within forced beam +c + isxtup = .true. + iip1 = iip + end if + else if (isxtup .and. nodur(ivx,iip).gt.0) then +c +c End of xtup within forced beam. Must count doubled notes +c + ndoub = 0 + do 1 iiip = iip1 , iip + if (btest(nacc(ivx,iiip),18)) ndoub = ndoub+1 +1 continue + multx = int(10.5+2.929+(0.952*alog(1.+iip-iip1+ndoub)- + * alog(nodur(ivx,iip)/2.))/0.69315)-10 + do 74 iiip = iip1 , iip +c mult(ivx,iiip) = multx + call setbits(mult(ivx,iiip),4,0,multx+8) +c +c Note the following still works after making mult only the 1st 4 bits. +c + if (btest(nacc(ivx,iiip),18)) + * mult(ivx,iiip) = mult(ivx,iiip)-1 + if (btest(nacc(ivx,iiip),19)) then + mult(ivx,iiip) = mult(ivx,iiip)+1 + else if (iiip .gt. 1) then + if (btest(nacc(ivx,iiip-1),19)) + * mult(ivx,iiip) = mult(ivx,iiip)+1 + end if +74 continue + isxtup = .false. + end if + if (btest(irest(ivx,iip),0)) then + nrests = nrests+1 + else + sum = sum+nolev(ivx,iip) + end if +9 continue +c +c Set beam up-down-ness +c + if (ifb.gt.0 .and. ulfbq(ivx,max(1,ifb)).ne.'x') then + if (ulfbq(ivx,ifb) .eq. 'f') then +c +c Get default, then trade "l" and "u" +c + ulq(ivx,numnow) = char(225-ichar( + * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1)))) + else + ulq(ivx,ifb) = ulfbq(ivx,ifb) + end if +c +c This probably works only because forced beams are done first, so they +c don't have to be re-sorted within each voice. ???? +c + else if (nvmx(iv) .eq. 2) then +c +c Multi-voice per staff +c + if (ivx .le. nv) then + ulq(ivx,numnow) = 'l' + else + ulq(ivx,numnow) = 'u' + end if + else +c +c Defaults +c + ulq(ivx,numnow) = + * ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1)) + end if + return + end + subroutine m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) +c +c This is called when (a) macro recording is just starting and +c (b) at the start of a new line, if recording is on +c + parameter (maxblks=4000) + character*128 lineq,lnholdq + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + logical mrecord,mplay,endmac + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + lbuf(1) = lbuf(1) + if (.not.mrecord) then +c +c Starting the macro +c + ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount + il1mac(macnum) = ilbuf-1 + ic1mac(macnum) = iccount + mrecord = .true. + end if + if (iccount .lt. 128) then + ndxm = index(lineq(iccount+1:128),'M') + if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M', + * 128-iccount) + if (ndxm .gt. 0) then +c +c This line ends the macro. +c + if (lineq(iccount+ndxm+1:iccount+ndxm+1) .ne. ' ') then + call errmsg(lineq,iccount+ndxm+1,ibarcnt-ibaroff+nbars+1, + * 'Improper macro termination!') + call stop1() + end if + ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm + il2mac(macnum) = ilbuf-1 + mrecord = .false. + end if + end if + return + end + subroutine make1bar(ibmrep,tglp1,tstart,cwrest,squez, + * istop,numbms,istart) + parameter (nm=24,mv=24576) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*10 figq + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig,bar1syst + common /comeskz2/ eskz2(nm,200) + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /combeam/ ibmtyp + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comas2/ nasksys,wasksys(800),elasksys(800) + common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comsln/ is1n1,is2n1,irzbnd,isnx + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,autofbon + character*128 litq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + integer cnn(nm),istart(80),istop(80),nxtnow(nm),ifbnow(nm), + * numbms(nm),mapfb(16) + real*4 xit(nm),t1xtup(20),tstart(80),squez(80) + character*1 ulfbq + character*79 inameq + character*20 voltxtq + common /comoct/ noctup + character*80 headrq,lowerq + logical cwrferm + common /comcwrf/ cwrferm(nm) + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + logical lower,cwrest(nm),vxtup,flgndb,btest,upslur, + * infbmx(nm),lowdot,inxtup(nm),drawbm + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /comstart/ facmtr + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac +c +c Above are factors for grace note, clef spacing. (fraction of wheadpt) +c In 1.04, moved to block data subprogram +c + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /comtol/ tol + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur, + * WrotePsslurDefaults + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /comntot/ ntot + if (ismidi) then +c +c Initialize for this bar the accidental counter for the midi file. +c naccim(icm) = # of accidentals from earlier in the bar +c + do 45 iv = 1 , nv + do 45 kv = 1 , nvmx(iv) + naccim(midchan(iv,kv)) = 0 +45 continue + end if +c +c Time from start of gulp to end of bar, used with forced beams +c + tglp2 = lenb0+ibar*lenb1 + if (lenb0 .gt. 0) tglp2 = tglp2-lenb1 + tglp1 = tglp2-lenbar +c +c infbmx will only be true if in xtup that is NOT in explicit forced beam. +c + do 1 iv = 1 , nv + do 1 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + cwrest(ivx) = .false. + infbmx(ivx) = .false. + inxtup(ivx) = .false. + if (ibar .gt. 1) then + nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1) + else + nn(ivx) = nib(ivx,ibar) + end if +1 continue +c +c initialize list note counter, time(iv), curr. note(iv). The loop to 4 +c ONLY initializes each voice. +c + in = 1 + nxtup = 0 + narp = 0 + do 4 iv = 1 , nv + do 4 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + cwrferm(ivx) = .false. + cnn(ivx) = 1 + ivxo(in) = ivx + ipo(in) = cnn(ivx) + tnote(in) = fnote(nodur,ivx,1,nacc) + to(in) = 0. + xit(ivx) = tnote(in) +c +c Note that xit(ivx) is to END of note in voice, but it1xtup is start time. +c + if (nodur(ivx,ipo(in)) .eq. 0) then +c +c First note of xtuplet at start of bar in voice ivx. +c + nxtup = nxtup+1 + nxtnow(ivx) = nxtup + inxtup(ivx) = .true. + t1xtup(nxtup) = 0. +c +c Xtup at start of bar. If no explicit forced beam, start one, set +c signal infbmx, and save number ifbnow for use at termination. +c + if (nfb(ivx) .gt. 0) then + do 60 ifb = 1 , nfb(ivx) + if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c No explicit fb here; so exit loop and insert one. +c + go to 61 + else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and. + * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c IS explicit fb here; must NOT insert one +c + go to 62 + end if +60 continue + end if +61 continue +c +c If here, xtup isn't in explicit fb, so must insert one +c + infbmx(ivx) = .true. + call addfb(nfb,ivx,t1xtup(nxtup)+ + * tglp1,t1fb,t2fb,ulfbq,ifbadd) + ifbnow(ivx) = ifbadd + end if +62 continue + if (abs(xit(ivx)-lenbar) .lt. tol) xit(ivx) = 1000. + in = in+1 +4 continue +c +c Build the list: This is a manual loop starting at 5 +c +5 continue +c +c Determine which voice comes next from end of notes done so far. +c tmin is the earliest ending time of notes done so far +c + tmin = 1000. + do 6 iiv = 1 , nv + do 6 kv = 1 , nvmx(iiv) + iivx = ivmx(iiv,kv) + tminn = min(tmin,xit(iivx)) + if(tminn .lt. tmin-tol) then + tmin = tminn + ivx = iivx + end if +6 continue + if (abs(tmin-1000.) .lt. tol) go to 7 + ivxo(in) = ivx + cnn(ivx) = cnn(ivx)+1 + ipo(in) = cnn(ivx) + to(in) = tmin +c +c Check if this voice is done +c + tnote(in) = fnote(nodur,ivx,cnn(ivx),nacc) + if (cnn(ivx) .eq. nn(ivx)) then + xit(ivx) = 1000. + else + xit(ivx) = xit(ivx)+tnote(in) + end if +c +c Flag xtups +c + if (nodur(ivx,cnn(ivx)) .eq. 0) then + if (.not.inxtup(ivx)) then +c +c First note of xtup, not at start of bar. +c + nxtup = nxtup+1 + nxtnow(ivx) = nxtup + inxtup(ivx) = .true. + t1xtup(nxtup) = xit(ivx)-tnote(in) +c +c (Note: can't be on last note in voice, so xit(ivx) <> 1000) +c Put xtuplet in a forced beam if not already in forced beam +c + if (nfb(ivx) .gt. 0) then + do 70 ifb = 1 , nfb(ivx) + if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c NO explicit bm; put one in +c + go to 71 + else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and. + * t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then +c +c IS explicit bm. Don't put one +c + go to 72 + end if +70 continue + end if +71 continue +c +c If here, no explicit bm, so put one in +c + infbmx(ivx) = .true. + call addfb(nfb,ivx,t1xtup(nxtup)+tglp1, + * t1fb,t2fb,ulfbq,ifbadd) + ifbnow(ivx) = ifbadd + end if +72 continue + else if (inxtup(ivx)) then +c +c This test is sufficient because already know nodur>0 +c + inxtup(ivx) = .false. + if (infbmx(ivx)) then +c +c Xtup is in auto-forced beam, so end it +c + t2fb(ivx,ifbnow(ivx)) = + * t1xtup(nxtnow(ivx))+nodur(ivx,cnn(ivx))+tglp1 + infbmx(ivx) = .false. + end if + end if + if (btest(irest(ivxo(in),ipo(in)),24) .or. + * btest(irest(ivxo(in),ipo(in)),30)) then +c +c For staff jumped beam, flag the first note (lowest voice) at same time. +c Later will start new notes group here. +c + inj = in + if (ivxo(in) .gt. 1) then + do 40 iin = in-1 , 1 , -1 + if (to(iin)+tol .lt. to(in)) go to 41 + if (abs(to(iin)-to(in)) .lt. tol) then + inj = iin + go to 40 + end if +40 continue + end if +41 continue + irest(ivxo(inj),ipo(inj)) = ibset(irest(ivxo(inj),ipo(inj)),29) + end if + in = in+1 + go to 5 +7 continue + ntot = in-1 + do 8 in = 1 , ntot-1 + tno(in) = to(in+1)-to(in) +8 continue + tno(ntot) = tnote(ntot) +c +c Debug writes +c +c write(*,'()') +c write(*,'(a)')' Greetings from PMXB' +c write(*,'(16i5)')(ivxo(in),in=1,ntot) +c write(*,'(16i5)')(ipo(in),in=1,ntot) +c write(*,'(16f5.1)')(to(in),in=1,ntot) +c write(*,'(16f5.1)')(tno(in),in=1,ntot) +c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot) +c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot) +c +c Done w/ list. Loop for parsing into note blocks: +c + ib = 1 + istart(1) = 1 + space(1) = 0. + in = 1 +c +c A manual loop to set space(ib) and istop(ib) +c +9 continue + + ivx = ivxo(min(in+1,ntot)) + ip = ipo(min(in+1,ntot)) + isl = islur(ivx,ip) + if (in.eq.ntot .or. ((ivx.eq.1 .and. + * (iand(isl,67109216).gt.0 .or. btest(ipl(1,ip),28) +c * .or. ornq(1,ip).eq.'g')) .or. btest(isl,15) )) then +c Bits 1-13: stmgx+Tupf._) +c 14: Down fermata, was F +c 15: Trill w/o "tr", was U + * .or. btest(iornq(1,ip),4))) .or. btest(isl,15) ) +c +c Checking for start of 2nd part of jumped beam +c + * .or. btest(irest(ivx,ip),29) ) then +c +c Bar end, segno, int. rpt or sig change, clef,end of 1st part of jumped beam; +c flow out of if-loop and into block-wrapup +c +c 10/18/97: Problem with clef alignment. Got isl{15} set on lowest-numbered +c voice, but it wasn't first in the list at the same time. So check if +c prior notes in list have same time +c 5/25/98: This stuff causes trouble with just "c2 Ct c", maybe when clef +c changes on last note in the list? +c + if (btest(isl,15) .and. in.lt.ntot) then + do 50 iin = in , 1 , -1 + if (tno(iin) .gt. tol) then + in = iin + islur(ivx,ip) = ibclr(islur(ivx,ip),15) + islur(ivxo(in+1),ipo(in+1)) = + * ibset(islur(ivxo(in+1),ipo(in+1)),15) + go to 51 + end if +50 continue +51 continue + end if + if (space(ib) .lt. tol) then + space(ib) = tno(in) + squez(ib) = 1. + end if + istop(ib) = in + else if (space(ib) .lt. tol) then +c +c space hasn't been set yet, so tentatively set: +c + space(ib) = tno(in) + if (space(ib) .lt. tol) then + in=in+1 + else + squez(ib) = getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + end if + go to 9 + else if (tno(in+1) .lt. tol) then +c +c This is not the last note in the group, so +c + in = in+1 + go to 9 + else if (abs(tno(in+1)-space(ib)) .lt. tol) then + xsquez = getsquez(in+1,ntot,space(ib),tnote,to) + if (abs(xsquez-squez(ib)) .lt. tol) then +c +c Keep spacing the same, update tentative stop point +c + in = in+1 + istop(ib) = in + go to 9 + end if + end if +c +c At this point istart and istop are good, so finalize block +c + tstart(ib) = to(istart(ib)) + if (istop(ib) .eq. ntot) go to 15 + ib = ib+1 + istart(ib) = istop(ib-1)+1 + in = istart(ib) +c +c Set tentative block space and squeeze-factor for upcoming block +c + space(ib) = tno(in) + if (space(ib).gt.tol) + * squez(ib)= getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + go to 9 +15 continue + nb = ib +c +c Invert the list of places into ipl(0-7), making it easier to analyze a voice +c + do 13 in = 1 , ntot +c +c ??? This may fix extra \loff's (bit 8 of ipl) in measures with >255 notes. +c +c ipl(ivxo(in),ipo(in)) = ior(ipl(ivxo(in),ipo(in)),in) + ipl2(ivxo(in),ipo(in)) = in +13 continue +c +c Compute elemskips from start of bar to each note in the bar, for beam slopes +c + eskzb = 0. + ib = 1 + do 30 in = 1 , ntot + if (in .eq. istart(ib)) then + deskb = squez(ib)*feon(space(ib)/squez(ib)) + else if (tno(in-1) .gt. tol) then + eskzb = eskzb+deskb + end if + eskz(ivxo(in),ipo(in)) = eskzb + eskz2(ivxo(in),ipo(in)) = eskzb + if (in .eq. istop(ib)) then + eskzb = eskzb+deskb + ib = ib+1 + end if +30 continue +c +c Debug writes +c +c print* +c write(*,'(16f5.1)')(eskz(ivxo(in),ipo(in)),in=1,ntot) +c print*,'PMXB has now got blocks' +c write(*,'(16i5)')(istart(ib),ib=1,nb) +c write(*,'(16i5)')(istop(ib),ib=1,nb) +c write(*,'(16f5.1)')(space(ib),ib=1,nb) +c write(*,'(16f5.1)')(squez(ib),ib=1,nb) +c write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in),nacc),in=1,ntot) +cc write(*,'(26i3)')(iand(islur(ivxo(in),ipo(in)),30720)/2048, +c * in=1,ntot) +c write(*,'(1x,26a3)')(ornq(ivxo(in),ipo(in)),in=1,ntot) +c +c +c Analyze for beams. +c + do 20 iv = 1 , nv + do 20 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + numbms(ivx) = 0 + mapfb(1) = 0 + mapfb(2) = 0 + mapfb(3) = 0 + mapfb(4) = 0 +c +c First forced beams. +c + if (nfb(ivx) .gt. 0) then +c +c tglp2 is time from start of gulp to end of current bar. +c + nfbbar = 0 + do 80 ifb = 1 , nfb(ivx) + if (t1fb(ivx,ifb).gt.tglp2-tol) go to 81 + nfbbar = nfbbar+1 + numbms(ivx) = numbms(ivx)+1 + numnew = numbms(ivx) +c +c Times from beginning of bar +c + itbb1 = int(t1fb(ivx,ifb)-tglp1+tol) + itbb2 = int(t2fb(ivx,ifb)-tglp1+tol) + do 83 ip = 1 , nn(ivx) + if (int(to(ipl2(ivx,ip))+tol) .eq. itbb1) then + nip1fb = ip + do 84 ip1 = ip , nn(ivx) + inip1 = ipl2(ivx,ip1) + if (abs(to(inip1)+tnote(inip1)-itbb2) .lt. tol) then + nip2fb = ip1 + itbb3 = itbb2-2 + go to 85 + end if +84 continue + end if +83 continue + print* + print*,'Timing problem w/ forced beams' + write(15,'(/a)')'Timing problem w/ forced beams' +85 continue + call logbeam(numnew,nip1fb,nip2fb) +c +c Set up mapfb for forced beam just logged: +c + ib1 = itbb1/2 + ib2 = itbb3/2 + ibrep = lenbar/ibmrep/2 + do 86 irep = 1 , ibmrep + ib1now = max(0,ib1-(irep-1)*ibrep) + ib2now = min(irep*ibrep-1,ib2-(irep-1)*ibrep) + mapnow = 0 + do 87 ib = ib1now , ib2now + mapnow = ibset(mapnow,ib) +87 continue + mapfb(irep) = ior(mapfb(irep),mapnow) +86 continue +c +c Since we are cycling thru forced beams, for those that start with a rest and +c have height & slope adjustments, move adjustments to next note. +c 060924: Copy to ALL later notes in fb, in case there's more than 1 rest at +c start of beam +c + if (btest(irest(ivx,nip1fb),0)) then +c call setbits(ipl(ivx,nip1fb+1),6,11, +c * igetbits(ipl(ivx,nip1fb),6,11)) +c call setbits(ipl(ivx,nip1fb+1),6,17, +c * igetbits(ipl(ivx,nip1fb),6,17)) +c call setbits(islur(ivx,nip1fb+1),2,27, +c * igetbits(islur(ivx,nip1fb),2,27)) + do 88 kp = nip1fb+1 , nip2fb + call setbits(ipl(ivx,kp),6,11, + * igetbits(ipl(ivx,nip1fb),6,11)) + call setbits(ipl(ivx,kp),6,17, + * igetbits(ipl(ivx,nip1fb),6,17)) + call setbits(islur(ivx,kp),2,27, + * igetbits(islur(ivx,nip1fb),2,27)) +88 continue + end if +80 continue +81 continue +c +c Slide down, reduce nfb(ivx). This lets us count up from 1 for each new bar. +c Remember, makeabar is called 1/bar, and it calls findbeam once per voice. +c + if (nfbbar .gt. 0) then + nfb(ivx) = nfb(ivx)-nfbbar + do 82 ifb = 1 , nfb(ivx) + t1fb(ivx,ifb) = t1fb(ivx,ifb+nfbbar) + t2fb(ivx,ifb) = t2fb(ivx,ifb+nfbbar) + ulfbq(ivx,ifb) = ulfbq(ivx,ifb+nfbbar) +82 continue + end if + end if + ifb = 0 +c +c Done with forced beam masks for this bar and voice. Now get normal beams. +c + call findbeam(ibmrep,numbms,mapfb) +20 continue + return + end + subroutine make2bar(ninow,tglp1,tstart,cwrest,squez, + * istop,numbms,istart,clefq) + parameter (nm=24,mv=24576) + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*10 figq + character*1 ulq,sepsymq,sq,chax + logical beamon,firstgulp,figbass,figchk,isfig,bar1syst,isbjmp, + * isbj2 + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /combeam/ ibmtyp + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comas2/ nasksys,wasksys(800),elasksys(800) + common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comsln/ is1n1,is2n1,irzbnd,isnx + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,issig,rpndot,autofbon + character*128 litq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + integer istart(80),istop(80),iaskb(nm),numbms(nm), + * nornb(nm),ihornb(nm,24),lcwr(nm),ibmcnt1(nm),ifig(2) + character*1 ulfbq,udqq,clefq(nm),slurudq + character*8 noteq + character*79 cwrq(nm),notexq,inameq + character*20 voltxtq + common /comoct/ noctup + character*80 soutq,headrq,lowerq + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + logical bspend,lower,cwrest(nm),vxtup, + * isgrace,isclef,nofirst,iscln,isdot,isflag, + * isacc,isfirst,flgndb,btest,stemup,upslur, + * isgaft,isarp,isrshft,isaccs,iscacc, + * lowdot,flipend,iscwr,isdotted,beamon1(nm) + real*4 ptgr(37),ptclef(nm),ptsndg(nm),eskndg(nm),tstart(80), + * squez(80) + logical cwrferm,drawbm + common /comcwrf/ cwrferm(nm) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xelsk(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /comstart/ facmtr + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac +c +c Factors for grace note, clef spacing. (fraction of wheadpt) +c In 1.04, moved to block data subprogram +c + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comtol/ tol + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,fontslur + * ,WrotePsslurDefaults + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + logical slmon,dbltie + common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm), + * naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl, + * slmon(0:nm),dbltie + common /comevent/ miditime,lasttime + logical kbdrests + common /comkbdrests/ levbotr(8),levtopr(8),kbdrests + logical secondgrace +c + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans +c +c +c Set up main ib loop within which a block (notes group) is written +c + do 25 iv = 1 , nv + do 25 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + ibmcnt(ivx) = 1 + ibmcnt1(ivx) = 1 + beamon(ivx) = .false. + beamon1(ivx) = .false. + nornb(ivx) = 0 + iaskb(ivx) = 1 + vxtup(ivx) = .false. + drawbm(ivx) = .true. +25 continue + naskb = 0 + ifig(1) = 1 + ifig(2) = 1 + ixtup = 0 + bspend = .false. + iscwr = .false. + rpndot = .false. + do 16 ib = 1 , nb +c +c Check for segno +c + if (btest(iornq(1,ipo(istart(ib))),4) .and. + * ivxo(istart(ib)).eq.1) then + if (noffseg.le.-10) then + write(noteq(1:5),'(1H{,i3,1H})')noffseg + lnoten = 5 + else if (noffseg.lt.0 .or. noffseg.ge.10) then + write(noteq(1:4),'(1H{,i2,1H})')noffseg + lnoten = 4 + else + write(noteq(1:1),'(i1)')noffseg + lnoten = 1 + end if + notexq = sq//'znotes'//sq//'segnoo'//noteq(1:lnoten)//'9' + lnote = 15+lnoten + do 130 iv = 2 , nv + if (lnote .gt. 60) then + if (islast) write(11,'(a)')notexq(1:lnote)//'%' + notexq = sepsymq(iv-1)//sq//'segnoo' + * //noteq(1:lnoten)//'9' + lnote = lnoten+9 + else + notexq = notexq(1:lnote)//sepsymq(iv-1)//sq//'segnoo' + * //noteq(1:lnoten)//'9' + lnote = lnote+lnoten+9 + end if +130 continue + if (islast) write(11,'(a)')notexq(1:lnote)//sq//'en' + lnote = 0 + end if +c +c Check for new clefs +c + isclef = .false. + if (btest(islur(ivxo(istart(ib)),ipo(istart(ib))),15)) + * then +c +c In preceding line, fl32 gave wrong result for ... .gt.0 !!! +c + do 140 in = istart(ib) , istop(ib) + if (btest(islur(ivxo(in),ipo(in)),11)) then + call wsclef(ivxo(in),ninow,clefq, + * iand(ishft(islur(ivxo(in),ipo(in)),-12),7)) + end if +140 continue + if (islast) write(11,'(a)')sq//'pmxnewclefs' + isclef = .true. + end if +c +c Start a notes group. We're just gonna define every one using pnotes{n}, +c where \def\pnotes#1{\vnotes#1\elemskip} +c + soutq = sq//'pnotes{' + eonsqz = squez(ib)*feon(space(ib)/squez(ib)) + if (eonsqz .gt. 9.995) then + write(soutq(9:12),'(f4.1)')eonsqz + else if (eonsqz .gt. 0.995) then + write(soutq(9:12),'(f4.2)')eonsqz + else if (eonsqz .gt. 0.095) then + soutq = soutq(1:8)//'0.' + write(soutq(11:12),'(i2)')nint(100*eonsqz) + else + soutq = soutq(1:8)//'0.0' + write(soutq(12:12),'(i1)')nint(100*eonsqz) + end if + soutq = soutq(1:12)//'}' + lsout = 13 +c +c Check whole block, flag accidentals etc that are too close, one per *time*. +c Note about bar starts and after rpt's/boublebars: There is an afterruleskip +c (fbar*wheadpt) following, but rpts seem to occupy some of that gap, so +c (dotsfac*wheadpt) is presumed to be filled up. +c + in = istart(ib)-1 + itrpt = -1 + itsig = -1 +c +c Begin big manual loop over notes in this block; ends at 112 +c +111 in = in+1 + if (in .gt. istop(ib)) go to 112 + ip = ipo(in) + ivx = ivxo(in) + if (ivx .le. nv) then + iv = ivx + else + do 128 iv = 1 , nv + if (nvmx(iv) .eq. 2 .and. ivmx(iv,2).eq. ivx) go to 129 +128 continue + print*,'Trouble finding iv!, ivx,nvmx,ivmx:',ivx,nvmx(1),nvmx(2) + print*,ivmx(1,1),ivmx(1,2),ivmx(2,1),ivmx(2,2) + stop + end if +129 continue +c +c Call precrd here so we know how much space to add for accid's in chords +c After calling precrd, icashft>0 means there is a shifted chordal accid (incl. +c main note. +c +c To call precrd, need up-downness, so must track if in beam. +c +c Deal w/ staff-jumping beams later +c if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) +c * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or. +c * btest(nacc(ivx,ip),21)) then +c if (.not.btest(irest(ivx,ip),24)) then + if ((numbms(ivx).gt.0 .and. ibmcnt1(ivx).le.numbms(ivx) + * .and. ibm1(ivx,ibmcnt1(ivx)) .eq. ip)) then + beamon1(ivx)=.true. + end if + icashft = 0 + if (btest(ipl(ivx,ip),10)) then +c +c There is a chord on this note. Need up-down-ness in precrd to auto shift for 2nds. +c + if (beamon1(ivx)) then + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt1(ivx)), + * .false.,icashft) + else + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip), + * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv), + * .false.,icashft) + end if + end if +c +c Turn beam off? +c + if (beamon1(ivx) .and. ibm2(ivx,ibmcnt1(ivx)).eq.ip) then + beamon1(ivx) = .false. + ibmcnt1(ivx) = ibmcnt1(ivx)+1 + end if +c +c Remember, rpts & internal sigs can only come at start of (internal) block +c + isacc = iand(nacc(ivx,ip),3).gt.0 + * .and. .not.btest(nacc(ivx,ip),17) + * .and. .not.btest(ipl(ivx,ip),10) +c +c i.e., do not set for chord. Now check for "(" as ornament on main note, +c +c!!! Need to do this for chord notes too. Maybe in chkarp? +c + isaccs = isacc .or. btest(iornq(ivx,ip),0) +c +c 5/15/02 Add check for ) ornament of prior note. +c 5/16 Nope...fails when grace intervenes. +c if (ip .gt. 1) then +c isaccs = isaccs .or. btest(iornq(ivx,ip-1),13) +c end if + isarp = btest(iornq(ivx,ip),27) + iscacc = .false. + if (btest(ipl(ivx,ip),10)) then +c +c There is a chord here; check for arpeggios and accidentals. Note accid shifts are +c not of concern here, only whether there's an accid, whick causes iscacc=.true. +c + iscacc = igetbits(nacc(ivx,ip),3,0).gt.0 .and. + * .not.btest(nacc(ivx,ip),17) + call chkarp(ncrd,icrdat,ivx,ip,iscacc,isarp) + end if +c +c When we get motivated, will do spacing for arpeggios here. +c + if (ivx.eq.1 .and. iand(islur(ivx,ip),96).gt.0) + * itrpt = nint(to(in)) + issig = btest(ipl(ivx,ip),28) + if (ivx.eq.1 .and. issig) itsig = nint(to(in)) + isgrace = btest(islur(ivx,ip),4) .and. + * .not.btest(ipl(ivx,ip),29) .and. .not.btest(ipl(ivx,ip),31) + isgaft = .false. + if (ip .gt. 1) then + xnd = tnote(ipl2(ivx,ip-1)) + isgaft = btest(ipl(ivx,ip-1),29) .or. btest(ipl(ivx,ip-1),31) + isgrace = isgrace .or. isgaft + end if + iscln = isclef .and. btest(islur(ivx,ip),11) +c +c Is prev. note non-beamed, up-stemmed, & flagged? Recall if ip>1, have nd +c + isflag = ip.gt.1 .and. xnd.gt.tol .and. xnd.lt.16.-tol + if (isflag) + * isflag = .not.btest(irest(ivx,ip-1),0) + * .and. udqq(nolev(ivx,ip-1), + * ncmid(iv,ip-1),islur(ivx,ip-1),nvmx(iv),ivx,nv).eq.'u' + if (isflag) then + do 116 ibmchk = 1 , numbms(ivx) + if (ip-1 .lt. ibm1(ivx,ibmchk)) then + go to 117 +c +c Add check for non-beamed xtuplets. May be problem with stem direction. +c +c else if (ip-1.le.ibm2(ivx,ibmchk)) then + else if (ip-1.le.ibm2(ivx,ibmchk) .and. + * .not.btest(islur(ivx,ibm1(ivx,ibmchk)),18)) then + isflag = .false. + go to 117 + end if +116 continue + end if +117 continue +c +c If isflag, then won't need to check for dot on prev. note. +c +c 5/16/02 ??? Try using this for ) ornament. +c + isflag = isflag .or. btest(iornq(ivx,ip-1),13) + isdot = ip.gt.1 + if (isdot) isdot = isdotted(nodur,ivx,ip-1) + isrshft = ip .gt. 1 + if (isrshft) isrshft = btest(irest(ivx,ip-1),20) + if (.not.(isaccs.or.isgrace.or.iscln.or.isflag.or.isrshft.or. + * isdot.or.btest(iornq(ivx,ip),26).or. + * btest(irest(ivx,ip),21).or.isarp.or. + * btest(irest(ivx,ip),27).or.iscacc)) go to 111 +c +c Here is an accid,grace,clef,flag,rtshft,dot,udsp,arpeg,left-shift. +c Compute pts, the total occupied space including prior notehead. +c + wheadpt1 = wheadpt*fullsize(iv) + pts = wheadpt1 +c +c Set up for possible cautionary accidental here +c + if (isaccs .or. iscacc) then + if (.not.btest(iornq(ivx,ip),31)) then + taccfac = accfac + else + taccfac = 1.4*accfac + end if + end if + if (isgrace) then + secondgrace = .false. + do 122 ig = 1 , ngrace + if (.not. isgaft) then + if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 123 + else if (ip .gt. 1) then + if (ipg(ig).eq.ip-1 .and. ivg(ig).eq.ivx) go to 123 + end if +122 continue + print*,'Problem finding grace index in makeabar' + stop +123 continue +c +c wgr = distance to backspace (in headwidths), less main acc. +c ptgr = same in pts,+ main acc. Not used for after-grace. Distance to backspace. +c spgr = total space needed (w/o main acc). +c Also, spgr is same for b4 or after, but xb4fac-space will be in diff. place. +c + if (nng(ig) .eq. 1) then + wgr = grafac + if (multg(ig) .eq. 0) wgr = wgr-.4 + else + wgr = nng(ig)*emgfac + do 126 ing = 2 , nng(ig) + if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac +126 continue + end if + if (graspace(ig) .gt. 0.) then +c +c User-defined space before grace +c + wgr = wgr+graspace(ig) + end if + ptgr(ig) = wgr*wheadpt1 + spgr = ptgr(ig)+xb4fac*wheadpt1 +c +c!!! May need to mod for chord accid's +c + if (isaccs .or. iscacc) ptgr(ig) = ptgr(ig) + taccfac*wheadpt1 + if (naccg(ngstrt(ig)) .gt. 0) spgr = spgr+wheadpt1*agc1fac + pts = pts+spgr +c +c Special check for after-grace on ip-1 and normal on ip. Must go back thru +c loop again for the normal grace. +c + if (isgaft .and. ig.lt.ngrace .and. .not.secondgrace) then + if (ipg(ig+1).eq.ip) then + secondgrace = .true. + ig = ig+1 + go to 123 + end if + end if + end if + if (iscln) then + pts = pts+clefac*wheadpt1 +c +c How far to backspace when printing the clef +c + ptclef(ivx) = 0. +c +c!!! May need to mod for chord accid's +c + if (isaccs .or. iscacc) + * ptclef(ivx) = ptclef(ivx)+taccfac*wheadpt1 + if (isgrace) ptclef(ivx) = ptclef(ivx)+spgr + end if + if (isrshft) then + pts = pts+rtshfac*wheadpt1 + else if (isflag) then + pts = pts+flagfac*wheadpt1 + else if (isdot) then + pts = pts+dotfac*wheadpt1 + end if + if (abs(to(in)-itrpt) .lt. tol) then +c +c Repeat, need a little extra space +c + pts = pts+dotsfac*wheadpt1 + end if + if (isarp) then + pts = pts+arpfac*wheadpt1 + end if +c +c Add in padding space +c + pts = pts+xspfac*wheadpt1 +c +c Now done with all items needing space except accidentals, +c accidental shifts, and left-notehead-shifts, and will later +c subtract a notehead if at start of bar. +c +c Get available space in elemskips (esk) +c +c isfirst = ip.eq.1 .or. to(in).eq.itrpt .or. +c * to(in) .eq. itsig + isfirst = ip.eq.1 .or. abs(to(in)-itrpt).lt.tol .or. + * abs(to(in)-itsig).lt.tol + if (isfirst) then +c +c At start of bar or after repeat sign or new signature +c +c if (to(in) .eq. itsig) then + if (abs(to(in)-itsig).lt.tol) then + esk = 0. + else + esk = fbar + end if + else +c +c Not 1st note of bar +c + esk = eskz(ivx,ip)-eskz(ivx,ip-1) + end if + if (isgrace) then +c +c Since graces can be very long, cannot assume no interference if prior +c note uses >1 noteskip. So must get elsk's back to prior note, whether or +c not it used only one noteskip. +c <<But if it was xtup. don't need to call eskb4.>>???? +c +c 10/8/05 Kluge to not zero out esk if in xtup +c + esksav = esk + if ((ip.le.2 .or. nodur(ivx,max(1,ip-2)).gt.0) .and. +c * to(in).ne.itsig) + * abs(to(in)-itsig).gt.tol) + * call eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk) + if (abs(esk) .lt. tol) esk = esksav + end if +c +c Done getting available elemskips. Remove headwidth if first. Must do here +c rather than earlier since check uses isfirst +c + if (isfirst) pts = pts-wheadpt1 +c +c Deal with accidental shifts and left-notehead shifts +c + if (btest(ipl(ivx,ip),10)) then +c +c In a chord +c + ptsl = 0. + if (btest(irest(ivx,ip),27)) ptsl = wheadpt1 + ptsadd = max(ptsl,icashft*.05*wheadpt1) +c +c Note: may have icashft=-20000 (if shftmin=-1000 in crdacc) but that's OK +c + else +c +c Not in a chord +c + ihshft = 0 + if (isaccs) then + ihshft = igetbits(nacc(ivx,ip),7,10) +c if (ihshft .ne. 0) ihshft = max(0,64-ihshft) + if (ihshft .ne. 0) ihshft = max(0,107-ihshft) + end if +c +c Check for left-shifted main note +c + if (btest(ipl(ivx,ip),8)) ihshft = max(20,ihshft) + ptsadd = ihshft*.05*wheadpt1 + end if + pts = pts+ptsadd + if (isgrace) ptgr(ig) = ptgr(ig)+ptsadd + if (iscln) ptclef(ivx) = ptclef(ivx)+ptsadd +c +c Left-shifted, non-chord note before? +c + if (ip .gt. 1) then + if (.not.btest(ipl(ivx,ip-1),10) .and. + * btest(irest(ivx,ip-1),27)) pts = pts-wheadpt1 + end if +c +c Try big accidentals first +c + ptbneed = pts + if (isaccs .or. iscacc) then + ptbneed = ptbneed+wheadpt1*bacfac + end if + if (poenom*esk .gt. ptbneed) then +c +c Set flag for big accidental +c + if (isacc) nacc(ivx,ip) = ibset(nacc(ivx,ip),3) + go to 99 + end if +c +c Cannot use big, so try small +c + ptsneed = pts + if (isaccs .or. iscacc) then + ptsneed = ptsneed+taccfac*wheadpt1 + end if + if (poenom*esk .lt. ptsneed) call addask(to(in),ptsneed, + * esk,fixednew,scaldold,0.,.false.) +99 continue + if (btest(iornq(ivx,ip),26)) then +c +c User-defined space. Warning, "zero" may change value in addask! +c + zero = 0. + call addask(to(in),ptsneed,zero, + * fixednew,scaldold,tglp1,.true.) + end if +c +c End of big manual loop over "in" for accidental checking +c + go to 111 +112 continue +c +c End of ask analysis for this block. +c +c Adjust eskz if there are added spaces. Corrects length of xtup brackets. +c + if (naskb.gt.0) call adjusteskz(ib,squez,istart,istop,poenom) +c +c Check for internal repeat or sig change. +c + if (ib.gt.1 .and. ivxo(istart(ib)).eq.1) then + iirpt = iand(islur(1,ipo(istart(ib))),67109216) + if (iirpt .gt. 0) then +c +c Internal repeat +c + if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%' + if (iirpt .eq. 96) then + if (islast) write(11,'(a)')sq//'leftrightrepeat' + fixednew = fixednew+lrrptfac*wheadpt + else if (btest(iirpt,5)) then + if (islast) write(11,'(a)')sq//'leftrepeat' + fixednew = fixednew+rptfac*wheadpt + else if (btest(iirpt,6)) then + if (islast) write(11,'(a)')sq//'rightrepeat' + fixednew = fixednew+rptfac*wheadpt + else if (btest(iirpt,8)) then + if (islast) write(11,'(a)')sq//'doublebar' + else + print*,'Unexpected mid-bar repeat command R*' + call stop1() + end if + scaldold = scaldold-fbar + end if + if (btest(ipl(1,ipo(istart(ib))),28)) then +c +c Internal signature change. +c + notexq = sq//'generalsignature{' + lnote = 18 + if (isig .lt. 0) then + notexq = notexq(1:lnote)//'-' + lnote = lnote+1 + end if + if (islast) write(11,'(a)')notexq(1:lnote) + * //chax(48+abs(isig))//'}%' + if (islast) write(11,'(a)')sq//'zchangecontext'//sq + * //'addspace{-.5'//sq//'afterruleskip}%' + lnote = 0 + end if + end if + flgndb = .false. +c +c Done with start-of-block stuff. Begin main loop over voices. +c + do 11 iv = 1 , nv + do 11 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + icm = midchan(iv,kv) +c +c A rather klugey way to set flag for figure in this voice +c Must always check figbass before figchk. +c + if (figbass) then + ivf = 0 + if (ivx .eq. 1) then + ivf = 1 + else if (ivx .eq. ivxfig2) then + ivf = 2 + end if + if (ivf.gt.0) figchk(ivf) = nfigs(ivf).gt.0 + end if + if (ivx .gt. 1) then + if (ivx .le. nv) then + call addstr(sepsymq(iv-1),1,soutq,lsout) + else + call addstr(sq//'nextvoice',10,soutq,lsout) + end if + end if + if (ihdht.gt.0 .and. ivx.eq.nv) then +c +c Write header. First adjust height if needed to miss barno. +c + if (bar1syst .and. iline.ne.1) then + ihdht = 15+irzbnd+isnx + end if +c +c Add user-defined vertical shift +c + ihdht = ihdht+ihdvrt + lchead = lenstr(headrq,80) + notexq = sq//'zcharnote{' + write(notexq(12:13),'(i2)')ihdht + notexq = notexq(1:13)//'}{'//sq//'bigfont'//sq//'kern-30pt ' + call addstr(notexq,34,soutq,lsout) + call addstr(headrq(1:lchead)//'}',1+lchead,soutq,lsout) + ihdht = 0 + end if + if (lower .and. ivx.eq.nv) then + lclow = lenstr(lowerq,80) + call addstr(sq//'zcharnote{-6}{'// + * sq//'tempo'//sq//'kern-10pt '// + * lowerq(1:lclow)//'}',33+lclow,soutq,lsout) + lower=.false. + end if + tnow = tstart(ib) + nofirst = .true. +c +c Done setting up voice ivx for start of block ib. Loop over notes in voice. +c + do 10 jn = istart(ib), istop(ib) + if (ivxo(jn) .ne. ivx) go to 10 + ip = ipo(jn) +c +c May have problem with not initializing islhgt, so do it here +c + islhgt = 0 +c + if (nofirst) then + noctup = 0 + if (ncmid(iv,ip) .eq. 23) noctup = -2 + nofirst = .false. + end if +c +c Check for internal floating figure (before last note of group). +c +12 if (figbass) then + if (ivx.eq.1 .or. ivx.eq.ivxfig2) then + ivf = 1 + if (ivx .gt. 1) ivf = 2 + if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.tnow-tol) + * then +c +c Bypassed figure location. Backup, place fig, return. +c + offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib) + call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq, + * lsout) + go to 12 + end if + end if + end if +c +c Put in \sk if needed +c + if (to(jn) .gt. tnow+tol) then + call addstr(sq//'sk',3,soutq,lsout) + tnow = tnow+space(ib) + go to 12 + end if +c +c Check for user-defined shifts +c + if (btest(irest(ivx,ip),15).or.btest(irest(ivx,ip),16)) + * call putshft(ivx,.true.,soutq,lsout) +21 if (iaskb(ivx).le.naskb .and. + * tnow.gt.task(iaskb(ivx))-tol) then + if (task(iaskb(ivx)) .gt. tstart(ib)-tol) then +c +c Insert placeholder for accidental skip +c + call addstr(sq//'ask ',9,soutq,lsout) + nasksys = nasksys+1 + wasksys(nasksys) = wask(iaskb(ivx)) + if (wask(iaskb(ivx)) .gt. 0.) then + elasksys(nasksys) = elask(iaskb(ivx)) + else +c +c This is a signal to permit negative ask's. Should really have elask>=0. +c + elasksys(nasksys) = -elask(iaskb(ivx)) + end if + end if +c +c May have skipped some task's in earlier blocks (due to void voice) +c + iaskb(ivx) = iaskb(ivx)+1 + go to 21 + end if + if (figbass) then + if (ivx.eq.1 .or. ivx.eq.ivxfig2) then + ivf = 1 + if (ivx .gt. 1) ivf = 2 + if (figchk(ivf) .and. + * abs(itfig(ivf,ifig(ivf))-tnow).lt.tol) then +c +c Figure on a note. NB: later special check for late figs. +c + call putfig(ivf,ifig(ivf),0.,figchk(ivf),soutq,lsout) + end if + end if + end if +c +c Check for new clef here. +c + if (isclef .and. btest(islur(ivx,ip),11)) then +c print*,'At clef insertion, ptclef:',ptclef(iv) + if (ptclef(iv) .gt. 0.) then + notexq = sq//'off{-' + if (ptclef(iv) .lt. 9.95) then + write(notexq(7:9),'(f3.1)')ptclef(iv) + lnote = 9 + else + write(notexq(7:10),'(f4.1)')ptclef(iv) + lnote = 10 + end if + notexq = notexq(1:lnote)//'pt}' + lnote = lnote+3 + call addstr(notexq,lnote,soutq,lsout) +c print*,'Just added: ',notexq(1:lnote) + end if + call clefsym(islur(iv,ip),notexq,lnote,nclef) + call addstr(notexq,lnote,soutq,lsout) + if (ptclef(iv) .gt. 0.) then + notexq = sq//'off{' + if (ptclef(iv) .lt. 9.95) then + write(notexq(6:8),'(f3.1)')ptclef(iv) + lnote = 8 + else + write(notexq(6:9),'(f4.1)')ptclef(iv) + lnote = 9 + end if + notexq = notexq(1:lnote)//'pt}' + lnote = lnote+3 + call addstr(notexq,lnote,soutq,lsout) + end if + end if +c +c Checking for literal TeX string BEFORE starting beams!! +c + if (btest(islur(ivx,ip),16)) then + do 124 il = 1 , nlit + if (iplit(il).eq.ip .and. ivlit(il).eq.ivx) go to 125 +124 continue + print*,'Problem finding index for literal string' + call stop1() +125 continue +c +c Write a type 1 tex string. +c + if (lenlit(il) .lt. 71) then +c +c Add normally +c + call addstr(litq(il),lenlit(il),soutq,lsout) + else +c +c Longer than 71. Write souq, Write string, start new soutq. +c + if (islast) write(11,'(a)')soutq(1:lsout)//'%' + if (islast) write(11,'(a)')litq(il)(1:lenlit(il))//'%' + lsout = 0 + end if + end if +c +c Arpeggio on a main (non-chordal) note? +c + if (btest(iornq(ivx,ip),27)) then +c call putarp(tnow,iv,ip,nolev(ivx,ip),ncmid(iv,ip), + call putarp(tnow,ivx,ip,nolev(ivx,ip),ncmid(iv,ip), + * soutq,lsout) + end if +c +c See if a beam starts here +c + if ((numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) + * .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) .or. + * btest(nacc(ivx,ip),21)) then + if (.not.btest(irest(ivx,ip),24)) then +c +c Not a jump start +c + call beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib) +c +c Shift beam start if notehead was shifted +c + if (btest(ipl(ivx,ip),8)) then + call addstr(sq//'loff{',6,soutq,lsout) + else if (btest(ipl(ivx,ip),9)) then + call addstr(sq//'roff{',6,soutq,lsout) + end if + if (lnote .gt. 0) call addstr(notexq,lnote,soutq,lsout) + if (btest(ipl(ivx,ip),8) .or. + * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout) + else +c +c Jump start. Set marker for second part of a jump beam. Note ivbj2 was set +c to 0 at end of first part of jump beam +c + ivbj2 = ivx +c +c Check for xtup since we bypassed beamstrt wherein vxtup is normally set +c + if (btest(irest(ivx,ip),28) .and. ixrest(ivx).ne.2) + * vxtup(ivx) = .true. +c +c Since beamstrt is not called, and drawbm is normally set there, need to set +c it here. This could cause problems if someone tries a staff-jumping, +c unbarred beam, which I'll deal with when it comes up. +c + drawbm(ivx) = .true. + end if + if (ixrest(ivx) .eq. 0) then + beamon(ivx) = .true. + bspend = .true. + if (.not.btest(irest(ivx,ip),24))bspend = .true. + end if + end if +c +c Setup for chords and possible slurs in chords +c + if (btest(ipl(ivx,ip),10)) then +c +c There is a chord on this note. Just rerun precrd. Klunky, but saves +c me from tracking down errors instroduced when I moved 1st call +c forward for accidental spacing analysis. +c + if (beamon(ivx)) then + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),ulq(ivx,ibmcnt(ivx)), + * .true.,icashft) + else + call precrd(ivx,ip,nolev(ivx,ip),nacc(ivx,ip), + * ipl(ivx,ip),irest(ivx,ip),udqq(nolev(ivx,ip), + * ncmid(iv,ip),islur(ivx,ip),nvmx(iv),ivx,nv), + * .true.,icashft) + end if + end if +c +c Is there slur or grace activity? +c + isgrace = btest(islur(ivx,ip),4) + if (ip .gt. 1) isgrace = isgrace.or.btest(ipl(ivx,ip-1),31) +c +c isgrace if not 1st note in bar and previous note has Way-after grace. +c + if (btest(islur(ivx,ip),0) .or. isgrace) then + if (btest(islur(ivx,ip),0)) then + if (fontslur) then +c +c Call routine for non-postscript slurs +c + call doslur(nolev(ivx,ip),isdat1,isdat2,isdat3,nsdat, + * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout, + * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip), + * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)), + * nacc(ivx,ip)) + else +c +c Postscript slurs +c + call dopsslur(nolev(ivx,ip),isdat1,isdat2,isdat3, + * isdat4,nsdat, + * ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout, + * ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip), + * iornq(ivx,ip),islhgt,tnote(ipl2(ivx,ip)), + * nacc(ivx,ip)) + end if + end if + if (isgrace) then +c +c Grace note. +c + iphold = ip + isgrace = .false. + if (ip .gt. 1) isgrace = btest(ipl(ivx,ip-1),31) + if (isgrace) iphold = iphold-1 + isgrace = isgrace .or. (.not.btest(ipl(ivx,ip),31) + * .and..not.btest(ipl(ivx,ip),29)) +c +c Place grace now if (a) Way-after from prev note and ip>1 or (b) Pre-grace +c on current note. Do A-grace on current note, and W-grace at barend, later. +c + if (isgrace) then + call dograce(ivx,iphold,ptgr,soutq,lsout,ncmid(iv,ip), + * nacc(ivx,ip),ig,ipl(ivx,iphold),.false., + * beamon(ivx),nolev(ivx,ip),ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),nv,ibmcnt(ivx), + * tnote(ipl2(ivx,ip)),ulq) + if (slurg(ig)) then +c +c Terminate slur started in dograce. Get direction of main note stem +c + if (.not.beamon(ivx)) then +c +c Separate note. Get stem direction. +c + stemup = udqq(nolev(ivx,ip),ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),ivx,nv) .eq. 'u' + else +c +c In a beam +c + stemup = ulq(ivx,ibmcnt(ivx)) .eq. 'u' + end if +c +c Stop the shift if whole note +c + stemup = stemup .or. + * tnote(ipl2(ivx,ip)).gt.63 + call endslur(stemup,.not.upg(ig),nolev(ivx,ip),0, + * ndxslur,0,ncmid(iv,ip),soutq,lsout,fontslur) + end if + end if + end if + if (btest(iornq(ivx,ip),24)) then +c +c Start slur on main note for After- or Way-after-grace. +c +c???? ndxslur = log2(33554431-listslur) + ndxslur = log2(16777215-listslur) +c +c Get note name +c + call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip)) +c +c Get slur direction +c + slurudq = 'u' + if (.not.beamon(ivx)) then + if (udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), + * nvmx(iv),ivx,nv) .eq. 'u') slurudq = 'd' + else + if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') slurudq = 'd' + end if +c +cc Replace ndxslur by 11-ndxslur when printing only. +c Replace ndxslur by 23-ndxslur when printing only. +c +c if (11-ndxslur .lt. 10) then + if (23-ndxslur .lt. 10) then +c notexq = sq//'islur'//slurudq//chax(59-ndxslur) + notexq = sq//'islur'//slurudq//chax(71-ndxslur) + * //noteq(1:lnoten) + call addstr(notexq,8+lnoten,soutq,lsout) + else if (23-ndxslur .lt. 20) then + notexq = sq//'islur'//slurudq//'{1'//chax(61-ndxslur) + * //'}'//noteq(1:lnoten) + call addstr(notexq,11+lnoten,soutq,lsout) + else + notexq = sq//'islur'//slurudq//'{2'//chax(51-ndxslur) + * //'}'//noteq(1:lnoten) + call addstr(notexq,11+lnoten,soutq,lsout) + end if +c call setbits(ipl(ivx,ip),4,23,ndxslur) + call setbits(ipl(ivx,ip),5,23,ndxslur) + if (btest(ipl(ivx,ip),31)) +c +c Starting slur on W-grace on THIS note. Record ndxslur. +c + * listslur = ibset(listslur,ndxslur) + end if + end if +c +c Process dynamic marks +c + if (btest(irest(ivx,ip),26)) then + call dodyn(ivx,ip, + * nolev(ivx,ip),ncmid(iv,ip),ipl(ivx,ip),islur(ivx,ip), + * irest(ivx,ip),nvmx(iv),nv,beamon(ivx),ihornb,nornb,ulq, + * ibmcnt(ivx),nodur(ivx,ip).ge.64,soutq,lsout) + end if +c +c Check for chord notes. Moved up from below, 10/27/96 so chord orns done 1st. +c + if (btest(ipl(ivx,ip),10)) then +c +c Need a duration to set type of note head +c +c if (.not. vxtup(ivx)) then +c +c Clumsy test, but vxtup is not set until main note is processed. +c + if (.not.(vxtup(ivx).or.btest(irest(ivx,ip),28))) then + nodu = nodur(ivx,ip) +c else if (mult(ivx,ip) .lt. 0) then + else if (iand(mult(ivx,ip),15)-8 .lt. 0) then + nodu = 32 + else + nodu = 16 + end if + call docrd(ivx,ip,nodu,ncmid(iv,ip),iv,tnow,soutq,lsout, + * ulq,ibmcnt(ivx),islur(ivx,ip),nvmx(iv),nv, + * beamon(ivx),nolev(ivx,ip),ihornb,nornb,stemlen, + * btest(nacc(ivx,ip),27),nacc(ivx,ip)) + end if +c +c Now that chords are done, add stuff to midi file +c +c if (ismidi) call addmidi(icm,nolev(ivx,ip), + if (ismidi) call addmidi(icm, + * nolev(ivx,ip)-iTransAmt(instno(iv)), +c + * iand(nacc(ivx,ip),7),isig,tnote(ipl2(ivx,ip)), + * btest(irest(ivx,ip),0),.false.) +c +c Check for breath or caesura +c + if (btest(iornq(ivx,ip),28)) then + call putcb(ivx,ip,notexq,lnote) + call addstr(notexq,lnote,soutq,lsout) + end if +c +c Check for main-note ornaments. ')' on dotted notes go in with note, not here. +c Bits 0-13: (stmgx+Tupf._) ; 14: Down fermata, was F +c 15: Trill w/o "tr", was U , 16-18 edit. accid., 19-21 TBD +c + isacc = iand(iornq(ivx,ip),4194287) .gt. 0 +c +c isacc=.true. if any ornament except segno +c + if (btest(iornq(ivx,ip),13) .and. nodur(ivx,ip).gt.0) then +c +c If ). is only ornament, bypass. If with others, temporarirly zero the bit. +c + if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then + if (iand(iornq(ivx,ip),516079) .eq. 0) then +c +c ). is the only non-segno ornament +c + isacc = .false. + else +c +c There are other ornaments in addition +c + rpndot = .true. + iornq(ivx,ip) = ibclr(iornq(ivx,ip),13) + end if + end if + end if + if (isacc .and. .not.cwrferm(ivx)) then +c +c Check for centered whole-bar rest with fermata (bits 10 or 14). +c + if (iand(iornq(ivx,ip),17408).gt.0 + * .and. btest(irest(ivx,ip),0) .and. + * nodur(ivx,ip).eq.lenbar .and. + * .not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)) then + cwrferm(ivx) = .true. + go to 30 + end if + call putorn(iornq(ivx,ip),nolev(ivx,ip),nolev(ivx,ip), + * nodur(ivx,ip),nornb,ulq,ibmcnt(ivx),ivx,ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),nv,ihornb,stemlen, + * notexq,lnote,ip,islhgt,beamon(ivx), + * btest(ipl(ivx,ip),10)) + call addstr(notexq,lnote,soutq,lsout) + end if + if (rpndot) then + iornq(ivx,ip) = ibset(iornq(ivx,ip),13) + rpndot = .false. + end if +30 continue +c +c Check for main note accidental +c + if (iand(nacc(ivx,ip),3).gt.0 .and. + * .not.btest(nacc(ivx,ip),17)) then + ihshft = igetbits(nacc(ivx,ip),7,10) + if (ihshft .ne. 0) ihshft=ihshft-107 + if (.not.btest(ipl(ivx,ip),10) .and. btest(ipl(ivx,ip),8)) +c +c Not a chord, and left-shifted main note, so left-shift accid +c + * ihshft = ihshft-20 + call doacc(ihshft,igetbits(nacc(ivx,ip),6,4), + * notexq,lnote,nacc(ivx,ip),nolev(ivx,ip),ncmid(iv,ip), + * btest(irest(ivx,ip),31)) + call addstr(notexq,lnote,soutq,lsout) + end if +c +c Lower dot for lower-voice notes. Conditions are: +c 1. Dotted time value +c 2. Lower voice of two +c 3. Note is on a line +c 4. Not a rest +c. 5. Flag (lowdot) is set to true +c 6. Not in an xtuplet +c + if (lowdot .and. nvmx(iv).eq.2 .and. ivx.le.nv + * .and. nodur(ivx,ip).ne.0) then + if (.not.btest(irest(ivx,ip),0) .and. + * 2**log2(nodur(ivx,ip)).ne.nodur(ivx,ip) .and. + * mod(nolev(ivx,ip)-ncmid(ivx,ip),2).eq.0) then + if (btest(irest(ivx,ip),19)) then +c +c Note already in movdot list. Drop by 2. +c + updot(ivx,ndotmv(ivx)+1) = + * updot(ivx,ndotmv(ivx)+1)-2. + else +c +c Not in list so just move it right now +c + call dotmov(-2.,0.,soutq,lsout, + * igetbits(islur(ivx,ip),1,3)) + end if + end if + end if +c +c Check for dotted notes with moved dots +c + if (btest(irest(ivx,ip),19)) then + ndotmv(ivx) = ndotmv(ivx)+1 + call dotmov(updot(ivx,ndotmv(ivx)),rtdot(ivx,ndotmv(ivx)), + * soutq,lsout,igetbits(islur(ivx,ip),1,3)) + end if +c +c Stemlength shortening? +c + if (btest(mult(ivx,ip),27)) then + stemshort = 4.66-.667*(igetbits(mult(ivx,ip),3,28)+1)*.5 + call addstr(sq//'stemlength{',12,soutq,lsout) + write(notexq,'(f4.2)')stemshort + call addstr(notexq(1:4)//'}',5,soutq,lsout) + else if (ip .gt. 1) then + if (btest(mult(ivx,ip-1),27)) +c +c Cancel shortening. Looks like it gets automatically restored if new inst. or +c new line, so no need to worry about affecting other lines +c + * call addstr(sq//'stemlength{4.66}',17,soutq,lsout) + end if +c +c Zero out slur-height marker for raising ornaments +c + islhgt = 0 +c +c Now start with spacing notes. Is a beam start pending? +c + if (bspend .and. + * ibm2(ivx,ibmcnt(ivx)).gt.ibm1(ivx,ibmcnt(ivx))) then + if (ixrest(ivx) .eq. 4) then +c +c Special path for single note at end of otherwise beamed xtup +c + ixrest(ivx) = 0 + else + call beamn1(notexq,lnote) + end if + bspend = .false. +c +c Is a beam ending? +c + else if (numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) +c * .and. ibm2(ivx,ibmcnt(ivx)) .eq. ip) then + * .and. (ibm2(ivx,ibmcnt(ivx)).eq.ip .or. + * btest(nacc(ivx,ip),20))) then + if (bspend) then +c +c Must be a single-note ending of a jump-beam +c + bspend = .false. + end if + call beamend(notexq,lnote) + if (.not.btest(nacc(ivx,ip),20)) then + vxtup(ivx) = .false. + nornb(ivx) = 0 + ibmcnt(ivx) = ibmcnt(ivx)+1 + beamon(ivx) = .false. + end if +c +c Or if we're in the middle of a beam +c + else if (numbms(ivx).gt.0 .and. beamon(ivx)) then + call beamid(notexq,lnote) +c +c Or whole-bar rest +c + else if (btest(irest(ivx,ip),0) + * .and. nodur(ivx,ip).eq.lenbar + * .and..not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0) + * .and..not.btest(irest(ivx,ip),25) + * .and..not.btest(islur(ivx,ip),29)) then +c +c Rule out pickup bar, blank rests, non-centered. Remember islur b19=> rp +c + cwrest(ivx) = .true. + iscwr = .true. + call notex(cwrq(ivx),lcwr(ivx)) + tnow = tnow+lenbar + go to 10 + else if (ixrest(ivx) .eq. 0) then +c +c Before writing note or rest, check for keyboard rest height adjustment. +c Conditions are 0. This is a non-blank rest +c 1. kbdrests = .true. +c 2. There are two voices on the staff +c 3. No user-def height adjustments have been applied (nolev<50) +cc 4. Not last note in bar +cc 5. Followed by note (add better test later) +c + if (kbdrests .and. btest(irest(ivx,ip),0) .and. + * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and. +c * nolev(ivx,ip).le.50 .and. ip.ne.nn(ivx) +c * .and. .not.(btest(irest(ivx,ip+1),0))) then + * nolev(ivx,ip).le.50) then +c +c Get reference level: next following note if no intervening blank rests, +c otherwise next prior note. +c +c levnext = nolev(ivx,ip+1)-ncmid(iv,ip)+4 ! Relative to bottom line + if (ip.ne.nn(ivx).and..not.btest(iornq(ivx,ip),30)) then +c +c Not the last note and not "look-left" for level +c + do 8 kkp = ip+1 , nn(ivx) + if (btest(islur(ivx,kkp),29)) go to 4 + if (.not.btest(irest(ivx,kkp),0)) then + levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line + go to 9 + end if +8 continue + end if +4 continue +c +c If here, there were no following notes or came to a blank rest, or +c "look-left" option set. So look before +c + if (ip .eq. 1) go to 2 ! Get out if this is the first note. + do 3 kkp = ip-1, 1, -1 + if (.not.btest(irest(ivx,kkp),0)) then + levnext = nolev(ivx,kkp)-ncmid(iv,kkp)+4 ! Relative to bottom line + go to 9 + end if +3 continue + go to 2 ! Pretty odd, should never be here, but get out if so. +9 continue +c +c Find note in other voice at same time +c + iupdown = sign(1,ivx-nv-1) + ivother = ivmx(iv,(3-iupdown)/2) + tother = 0. + do 5 kkp = 1 , nib(ivother,ibar) + if (abs(tother-tnow) .lt. tol) go to 6 + tother = tother+nodur(ivother,kkp) +5 continue +c +c If here, then no note starts in other voice at same time, so set default +c + levother = -iupdown*50 + go to 7 +6 continue +c +c If here, have just identified a simultaneous note or rest in other voice +c + if (.not.btest(irest(ivother,kkp),0)) then ! Not a rest, use it + levother = nolev(ivother,kkp)-ncmid(iv,ip)+4 + else + if (nodur(ivother,kkp) .eq. nodur(ivx,ip)) then +c +c Rest in other voice has same duration, get out (so defualt spacing is used) +c + go to 2 + end if + levother = -iupdown*50 + end if +7 continue + indxr = log2(nodur(ivx,ip))+1 + if (iupdown .lt. 0) then + levtop = levtopr(indxr) + iraise1 = levother-levtop-3 ! Based on other note + iraise2 = levnext-levtop ! Based on following note + if (indxr.eq.5 .and. levnext.lt.1) iraise2=iraise2+2 + iraise = min(iraise1,iraise2) + if (mod(iraise+50,2).eq.1 .and. + * iraise+levtop.gt.-1) iraise = iraise-1 + else + levbot = levbotr(indxr) + iraise1 = levother-levbot+3 + iraise2 = levnext-levbot + if (indxr.eq.5 .and. levnext.gt.8) iraise2=iraise2-1 + iraise = max(iraise1,iraise2) + if (mod(iraise+50,2).eq.1 .and. + * iraise+levbot.le.9) iraise = iraise-1 + end if + nolev(ivx,ip) = 100+iraise + end if +2 continue +c +c Write a separate note or rest +c + call notex(notexq,lnote) + end if +c +c Right offset? This may cause trouble +c + if (btest(ipl(ivx,ip),8)) then + call addstr(sq//'loff{',6,soutq,lsout) + else if (btest(ipl(ivx,ip),9)) then + call addstr(sq//'roff{',6,soutq,lsout) + end if + if (ixrest(ivx).eq.0 .and. lnote.gt. 0) + * call addstr(notexq,lnote,soutq,lsout) + if (btest(ipl(ivx,ip),8) .or. + * btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout) +c +c Terminate user-defined offsets. Fix format +c + if (btest(irest(ivx,ip),15) .or. btest(irest(ivx,ip),17)) + * call putshft(ivx,.false.,soutq,lsout) +c +c Deal with After- and Way-after-graces. First, if end of bar, compute space +c needed since it wasn't done during general ask-checks. If extra space is +c rq'd, convert GW to GA. Therefore GW at end of bar never needs extra sp. +c But will still need to add extra space as hardspace. +c + if (ip.eq.nn(ivx) .and. (btest(ipl(ivx,ip),31).or. + * btest(ipl(ivx,ip),29))) then + do 77 ig = 1 , ngrace + if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 78 +77 continue + print*,'Problem finding grace index at "do 77"' + call stop1() +78 continue +c +c Get elemskip to end of bar. WON'T WORK IF XTUPS !! +c + esk = 0. + do 40 iib = ib , nb + if (iib .eq. ib) then + itleft = nint(to(ipl2(ivx,ip))) + else + itleft = nint(tstart(ib)) + end if + if (iib .lt. nb) then + itright = nint(tstart(iib+1)) + else + itright = lenbar + end if + esk = esk+feon(space(ib))* + * (itright-itleft)/space(ib) +40 continue + ptsavail = poenom*esk-wheadpt + if (nng(ig) .eq. 1) then + wgr = grafac + else + wgr = nng(ig)*emgfac + do 41 ing = 1 , nng(ig) + if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac +41 continue + end if + ptgr(ig) = wgr*wheadpt + ptsneed = (wgr+0.5)*wheadpt + ptsndg(ivx) = 0. + if (ptsavail .lt. ptsneed) then + ptsndg(ivx) = ptsneed + eskndg(ivx) = esk + if (btest(ipl(ivx,ip),31)) then +c +c Convert GW to GA +c + ipl(ivx,ip) = ibset(ibclr(ipl(ivx,ip),31),29) + end if + end if + end if +c +c Check for GA +c + if (btest(ipl(ivx,ip),29)) + * call dograce(ivx,ip,ptgr,soutq,lsout,ncmid(iv,ip), + * nacc(ivx,ip),ig,ipl(ivx,ip),.false., + * .false.,0,0,0,0,0,0,0.,ulq) +c +c Update running time +c + tnow = tnow+space(ib) +10 continue +c +c Have finished last note in this voice and block +c + itendb = nint(to(istop(ib))+space(ib)) + if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then + ivf = 1 + if (ivx .gt. 1) ivf = 2 +17 if (figchk(ivf) .and. itfig(ivf,ifig(ivf)).lt.itendb) then +c +c There's at least one figure left. offnsk could be <0 +c + offnsk = (tnow-itfig(ivf,ifig(ivf)))/space(ib) + call putfig(ivf,ifig(ivf),offnsk,figchk(ivf),soutq,lsout) + go to 17 + end if + end if +c +c Check for flag, dot, or upstem on last note of bar. +c + if (ib .eq. nb) then + ip = ipo(ipl2(ivx,nn(ivx))) + flgndv(ivx) = 0. + if (abs(tnote(ipl2(ivx,ip))-space(ib)).lt.tol) then + if (space(ib) .lt. 16.-tol) then +c +c Note in last space, smaller than a quarter note. +c + if ((.not.btest(irest(ivx,ip),0) .and. + * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), + * nvmx(iv),ivx,nv).eq.'u') + * .or. isdotted(nodur,ivx,ip)) then +c +c Upstem non-rest, or dotted +c + if (numbms(ivx).gt.0 + * .and. ip.eq.ibm2(ivx,max(1,numbms(ivx))) + * .and. .not.isdotted(nodur,ivx,ip)) + * then +c +c In beam and not dotted, so use smaller space +c + flgndv(ivx) = upstmfac + else + flgndv(ivx) = flagfac + end if + end if + else +c +c Last space, nonflagged (no beam) only worry dot or up +c + if (isdotted(nodur,ivx,ip)) then + flgndv(ivx) = flagfac + else if (tnote(ipl2(ivx,ip)).lt.64 .and. + * udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), + * nvmx(iv),ivx,nv).eq.'u') then +c +c Upstem on last note , non-flagged +c + flgndv(ivx) = upstmfac + end if + end if + end if +c +c Check for right-shifted chordal note +c + if (btest(irest(ivx,ip),20)) flgndv(ivx) = rtshfac + flgndb = flgndb .or. flgndv(ivx).gt.0. + if (ismidi) then +c +c For midi, set flags for accidentals on last note of bar. Assume they affect +c first note of next bar whether or not tied. +c Note has already been done, so next entry into addmidi is 1st in new bar. +c First do main note, then chord notes +c +c Gyrations needed to account for multi-bar tied full-bar notes? +cc Old old lbacc(icm) = iand(nacc(ivx,ip),7) +c New old if (lbacc(icm).eq.0) lbacc(icm) = iand(nacc(ivx,ip),7) +c + if (iand(nacc(ivx,ip),7) .gt. 0) then +c +c Explicit accidental on last main note in bar +c + do 55 kacc = 1 , naccbl(icm) + if (laccbl(icm,kacc) .eq. nolev(ivx,ip)) go to 56 +55 continue + naccbl(icm) = naccbl(icm)+1 + laccbl(icm,naccbl(icm)) = nolev(ivx,ip) + jaccbl(icm,naccbl(icm)) = iashft(iand(nacc(ivx,ip),7)) + end if +56 continue + if (btest(ipl(ivx,ip),10) .and. crdacc) then + do 57 icrd = icrd1 , icrd2 + iacc = igetbits(icrdat(icrd),3,20) + if (iacc .gt. 0) then +c +c Explicit accidental on chord note at end of bar +c + nolevc = igetbits(icrdat(icrd),7,12) + do 58 kacc = 1 , naccbl(icm) + if (laccbl(icm,kacc) .eq. nolevc) go to 59 +58 continue + naccbl(icm) = naccbl(icm)+1 + laccbl(icm,naccbl(icm)) = nolevc + jaccbl(icm,naccbl(icm)) = iashft(iacc) + end if +59 continue +57 continue + end if +c if (lbacc(icm).eq.0 .and. accb4(icm)) then + do 65 kacc = 1 , naccim(icm) +c +c If naccim(icm)>0, +c possible implicit accidental from earlier in the bar. Check for prior accid +c in this bar at relevant note levels, main and chord notes. Only act if no +c explicit action from just above. Assuming any accid on last note in bar, +c either explicit or implicit, has same effect on 1st note of next bar. +c + if (nolev(ivx,ip) .eq. laccim(icm,kacc)) go to 66 + if (btest(ipl(ivx,ip),10)) then + do 67 icrd = icrd1 , icrd2 + if (iand(ishft(icrdat(icrd),-12),127) .eq. + * laccim(icm,kacc)) go to 66 +67 continue + end if + go to 65 +66 continue +c +c So far we know there is a main or chord note at level laccim(icm,kacc). So +c it will get a bl-accid if it didn't just already get one. +c + do 68 macc = 1 , naccbl(icm) + if (laccbl(icm,macc) .eq. laccim(icm,kacc)) go to 65 +68 continue + naccbl(icm) = naccbl(icm)+1 + laccbl(icm,naccbl(icm)) = laccim(icm,kacc) + jaccbl(icm,naccbl(icm)) = jaccim(icm,kacc) +65 continue + end if + end if +11 continue +c +c Close out the notes group +c + call addstr(sq//'en',3,soutq,lsout) + if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%' +16 continue +c +c Check for way-after graces at end of bar. We could not link these to notes +c as in midbar since there is no note following grace! Also, set flag if +c hardspace is needed. Also, save nvmx, ivmx for use in space checks on reloop. +c + isgrace = .false. + do 75 iv = 1 , nv + nvmxsav(iv) = nvmx(iv) + do 75 kv = 1 , nvmx(iv) + ivmxsav(iv,kv) = ivmx(iv,kv) + ivx = ivmx(iv,kv) + ptsgnd = 0. + if ((btest(ipl(ivx,nn(ivx)),29).or.btest(ipl(ivx,nn(ivx)),31)) + * .and. ptsndg(ivx).gt.0.) then + flgndb = .true. + if (ptsndg(ivx) .gt. ptsgnd) then + ptsgnd = ptsndg(ivx) + eskgnd = eskndg(ivx) + end if + end if + if (btest(ipl(ivx,nn(ivx)),31)) then +c +c This voice has a way-after grace here at end of bar +c + if (.not.isgrace) then +c +c This is the first one, so set up the string +c + isgrace = .true. + ivlast = 1 + soutq = sq//'znotes' + lsout = 7 + end if + do 76 iiv = ivlast , iv-1 + call addstr(sepsymq(iiv),1,soutq,lsout) +76 continue + ivlast = iv +c +c No need to put in 'nextvoice', even if 2 lines/staff +c + call dograce(ivx,nn(ivx),ptgr,soutq,lsout,ncmid(iv,nn(ivx)), + * nacc(ivx,nn(ivx)),ig,ipl(ivx,nn(ivx)),.true., + * .false.,0,0,0,0,0,0,0.,ulq) + end if +75 continue + if (isgrace) then + call addstr(sq//'en%',4,soutq,lsout) + if (islast .and. lsout .gt. 0) write(11,'(a)')soutq(1:lsout) + end if + lsout = 0 +c +c Write multibar rest. Assuming nv = 1 and do not worry about cwbrest +c This has to be the only use of atnextbar +c +c if (ibar .eq. ibarmbr) then + if (ibar.eq.ibarmbr .and. islast) then +c call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes'//sq// +c * 'mbrest{',30,soutq,lsout) +c ndig = int(alog10(mbrest+.01))+1 +c write(soutq(31:33),'(i'//chax(48+ndig)//')')mbrest +c lsout = lsout+ndig +c call addstr('}{',2,soutq,lsout) +c mtrspc = .5+xb4mbr +c xb4mbr = 0. +c if (mtrspc .eq. 0) then +c ndig = 1 +c else +c ndig = int(alog10(mtrspc+.01))+1 +c end if +c write(soutq(lsout+1:lsout+2),'(i'//chax(48+ndig)//')')mtrspc +c lsout = lsout+ndig +c call addstr('}0'//sq//'en}%',7,soutq,lsout) +c if (islast) write(11,'(a)')soutq(1:lsout) +c lsout = 0 +c ndig = int(alog10(mbrest-1+.01))+1 +c if (mbrest.eq.1) ndig=1 +c if (islast) write(11,'(a14,i'//chax(48+ndig)//',a1)') +c * sq//'advance'//sq//'barno',mbrest-1,'%' +c++ + soutq = sq//'def'//sq//'atnextbar{'//sq//'znotes' + lsout = 22 + notexq = sq//'mbrest' + lnote = 7 + call istring(mbrest,noteq,len) + notexq = notexq(1:lnote)//noteq(1:len) + lnote = lnote+len + mtrspc = .5+xb4mbr + xb4mbr = 0. + call istring(mtrspc,noteq,len) + notexq = notexq(1:lnote)//noteq(1:len)//'0' + lnote = lnote+len+1 + do 62 iv = 1 , nv + call addstr(notexq,lnote,soutq,lsout) + if (iv .lt. nv) call addstr(sepsymq(iv),1,soutq,lsout) +62 continue + call addstr(sq//'en}%',5,soutq,lsout) + write(11,'(a)')soutq(1:lsout) + lsout = 0 + if (mbrest .gt. 1) then + ndig = int(alog10(mbrest-1+.01))+1 + write(11,'(a14,i'//chax(48+ndig)//',a1)') + * sq//'advance'//sq//'barno',mbrest-1,'%' + end if + else if (iscwr) then +c +c Centered whole-bar rests +c + call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes',22, + * soutq,lsout) + do 60 iv = 1 , nv + lnote = 0 + do 61 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + if (cwrest(ivx)) then + if (lnote .eq. 0) then + notexq = sq//'centerbar{' + lnote = 11 + end if + if (.not.cwrferm(ivx)) then + if (lcwr(ivx).ge.11 .and. cwrq(ivx)(11:11).ne.'p') then +c +c Kluge to use new definitions for centered, stacked rests +c + if (cwrq(ivx)(2:10).eq.'liftpause' .or. + * cwrq(ivx)(2:10).eq.'liftPAuse') + * cwrq(ivx)(10:10) = 'c' + end if + notexq = notexq(1:lnote)//cwrq(ivx)(1:lcwr(ivx)) + lnote = lnote+lcwr(ivx) + else +c +c Fermata on centered rest. Will need to fix up level. +c 12/6/07 shift it left so it's centered over rest +c +c notexq = notexq(1:lnote) +c * //sq//'fermataup7'//cwrq(ivx)(1:lcwr(ivx)) +c lnote = lnote+11+lcwr(ivx) +c + notexq = notexq(1:lnote)//sq//'loffset{.39}{' + * //sq//'fermataup7}'//cwrq(ivx)(1:lcwr(ivx)) + lnote = lnote+26+lcwr(ivx) + cwrferm(ivx) = .false. + end if + end if +61 continue + if (lnote .gt. 0) call addstr(notexq(1:lnote)//'}',lnote+1, + * soutq,lsout) + if (iv .ne. nv) call addstr(sepsymq(iv),1,soutq,lsout) +60 continue + call addstr(sq//'en}',4,soutq,lsout) + if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%' + end if +c +c End of block for centered whole-bar rests and multi-bar rests +c +c If at end of block, save durations of last notes in bar, for possible use +c if clef changes at start of next bar +c + if (ibar .eq. nbars) then + do 63 iv = 1 , nv + do 63 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) +c prevtn(ivx) = tnote(iand(ipl(ivx,nn(ivx)),255)) + prevtn(ivx) = tnote(ipl2(ivx,nn(ivx))) +63 continue + end if +c +c Update time for midi. This is only used for the event track +c + if (ismidi) then + miditime = miditime+15*lenbar +c +c If pickup, write the real time signature to the event track. Cannot use +c mtrnuml since it was reset to 0, have to recompute it +c + if (lenb0 .eq. lenbar) + * call midievent('m',mtrdenl*lenb1/64,mtrdenl) + end if + return + end + subroutine makeabar() +c +c On input, have pseudo-durations in nodur(ivx,ip). Not real durations for +c xtups, since only last note of xtup gets non-zero nodur, which +c corresponds to single note of full length of xtup. +c In this subroutine we make an ordered list of all notes in all voices. +c ilnc = list note counter +c ivxo(ilnc), ipo(ilnc) = voice# and position in voice of ilnc-th note. +c to(ilnc) = real start time of note in PMX-units (64=whole note) +c tno(ilnc) = time to next event in the bar. +c tnote(ilnc) = actual duration of note +c Then run thru list, grouping consecutive notes into \notes groups ib. +c space(ib) = real time unit for the \notes group +c squez(ib) = factor on space to get effective space. This will be 1 if +c there is a note exactly spanning each interval of space, and +c <1 if not. +c Details: let eon = elemskips per noteskip (like length). Basic formula is +c eon = sqrt(space/2.) +c If tgovern >= space, then +c eon = sqrt(tgovern/2)*(space/tgovern) = space/sqrt(2*tgovern). +c Time needed to give this eon using basic formula is +c teq = space**2/tgovern +c Factor on space to get teq is +c squez(ib) = space/tgovern +c The eon for each ib can then be computed based on time of space*squez. +c Iff squez = 1, there is a note spanning every increment in the \notes group. +c +c tnminb = minimum time span in the bar for increments spanned by notes, +c i.e., with squez=1. Use after parsing into line to decide if +c spacing needs to be "flattened" among notes groups. +c + common /comtol/ tol + parameter (nm=24,nkb=3999,maxblks=4000) + common /a1ll/ iv,ivxo(600),ipo(600),to(600),tno(600),nnl(nm), + * nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount, + * nbars,itsofar(nm),nib(nm,15),nn(nm), + * rest(nm,200),lenbr0,lenbr1,firstline,newmeter + common /linecom/ elskb,tnminb(nkb) + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) + logical rest,firstline,newmeter,gotclef + integer cnn(nm),istart(80),istop(80) + real*4 xit(nm),space(80),tstart(80),squez(80),tnote(600) + elskb = 0. + tnminb(ibarcnt) = 1000. + do 1 iv = 1 , nv + do 1 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + if (ibar .gt. 1) then + nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1) + else + nn(ivx) = nib(ivx,ibar) + end if +1 continue +c +c initialize list note counter, time(iv), curr. note(iv) +c + ilnc = 1 + do 4 iv = 1 , nv + do 4 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + cnn(ivx) = 1 + ivxo(ilnc) = ivx + ipo(ilnc) = 1 + to(ilnc) = 0. + tnote(ilnc) = fnote(nodur,ivx,1,nacc) + xit(ivx) = tnote(ilnc) + if (abs(xit(ivx)-lenbar).lt.tol) xit(ivx) = 1000. + ilnc = ilnc+1 +4 continue +c +c Build the list +c +5 continue +c +c Determine which voice comes next from end of notes done so far. +c tmin is the earliest ending time of notes done so far +c + tmin = 1000. + do 6 iv = 1 , nv + do 6 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + tminn = min(tmin,xit(ivx)) + if(tminn .lt. tmin) then + tmin = tminn + ivnext = ivx + end if +6 continue + if (tmin .gt. 999.) go to 7 + ivxo(ilnc) = ivnext + cnn(ivnext) = cnn(ivnext)+1 + ipo(ilnc) = cnn(ivnext) + to(ilnc) = tmin +c +c Check if this voice is done +c + tnote(ilnc) = fnote(nodur,ivnext,cnn(ivnext),nacc) + if (cnn(ivnext) .eq. nn(ivnext)) then + xit(ivnext) = 1000. + else + xit(ivnext) = xit(ivnext)+tnote(ilnc) + end if + ilnc = ilnc+1 + go to 5 +7 continue + ntot = ilnc-1 + if (ntot .gt. 600) then + call printl(' ') + call printl('Cannot have more than 600 notes per bar, stopping') + call stop1() + end if + do 8 in = 1 , ntot-1 + tno(in) = to(in+1)-to(in) +8 continue + tno(ntot) = fnote(nodur,ivxo(ntot),ipo(ntot),nacc) + tnote(ntot) = tno(ntot) +c +c Debug writes +c +c write(*,'()') +c write(*,'(16i5)')(ivxo(in),in=1,ntot) +c write(*,'(16i5)')(ipo(in),in=1,ntot) +c write(*,'(16f5.1)')(to(in),in=1,ntot) +c write(*,'(16f5.1)')(tno(in),in=1,ntot) +c write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot) +c write(*,'(16f5.1)')(tnote(in),in=1,ntot) +c +c Done w/ list. Initialize loop for building note blocks: +c + ib = 1 + istart(1) = 1 + space(1) = 0. + in = 1 +c +c Start the loop +c +9 continue + if (in .eq. ntot) then + if (space(ib) .lt. tol) then + space(ib) = tno(in) +c +c Last gap in bar is spanned by a note, so cannot need a squeeze. +c + squez(ib) = 1. + end if + istop(ib) = ntot +c +c From here flow out of this if block and into block-setup +c + else if (space(ib) .lt. tol) then +c +c space hasn't been set yet, so tentatively set: +c + space(ib) = tno(in) + if (space(ib) .lt. tol) then + in=in+1 + else +c +c Tentative space tno(in) is non-zero. Set squez, which will be kept (since +c it is a unique property of the particular increment starting here) : +c + squez(ib) = getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + end if + go to 9 + else if (tno(in+1) .lt. tol) then +c +c This is not the last note in the space, so +c + in = in+1 + go to 9 + else if (abs(tno(in+1)-space(ib)) .lt. tol) then +c +c Next increment has same space. Does it have same squez? +c + xsquez = getsquez(in+1,ntot,space(ib),tnote,to) +c +c If it does have the same squez, loop, otherwise flow out +c + if (abs(xsquez-squez(ib)) .lt. tol) then +c +c Keep spacing the same, update tentative stop point +c + in = in+1 + istop(ib) = in + go to 9 + end if + end if +c +c At this point istart, istop, space, and squez are good, so close out block +c + tstart(ib) = to(istart(ib)) +c +c Compute elemskips assuming no flattening to increase min space. The formula +c is only correct if f1eon(t) = sqrt(t/2); more generally (after possible +c flattening in pmxb), elsperns = squez*feon(space/squez) +c + elsperns = f1eon(space(ib)*squez(ib)) + if (istop(ib) .eq. ntot) then + nnsk = nint((lenbar-tstart(ib))/space(ib)) + else + nnsk = nint((to(istop(ib)+1)-tstart(ib))/space(ib)) + end if + elskb = elskb+elsperns*nnsk + if (nptr(ibarcnt+1) .gt. nptr(ibarcnt)) then + call catspace(space(ib),squez(ib),nnsk) + else +c +c This is the first entry for this bar +c + nnpd(nptr(ibarcnt)) = nnsk + durb(nptr(ibarcnt)) = space(ib) + sqzb(nptr(ibarcnt)) = squez(ib) + nptr(ibarcnt+1) = nptr(ibarcnt+1)+1 + end if +c +c Update minimum space spanned by a note +c + if (abs(squez(ib)-1) .lt. tol) + * tnminb(ibarcnt) = min(tnminb(ibarcnt),space(ib)) + if (istop(ib) .eq. ntot) go to 15 +c +c End of spatial accounting for now +c + ib = ib+1 + istart(ib) = istop(ib-1)+1 + in = istart(ib) +c +c Set tentative block space for new block +c + space(ib) = tno(in) + if (space(ib).gt.tol) + * squez(ib)= getsquez(in,ntot,space(ib),tnote,to) + istop(ib) = in + go to 9 +15 continue +c nb = ib +c +c Debug writes +c +c write(*,'(16i5)')(istart(ib),ib=1,nb) +c write(*,'(16i5)')(istop(ib),ib=1,nb) +c write(*,'(16f5.1)')(space(ib),ib=1,nb) +c write(*,'(16f5.1)')(squez(ib),ib=1,nb) +c + return + end + subroutine midievent(typeq,in1,in2) +c +c We now store "conductor" events in mmidi(numchan,.), and count bytes +c with imidi(numchan) +c + parameter (nm=24,mv=24576) + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /comevent/ miditime,lasttime + character*1 typeq + idur = isetvarlen(miditime-lasttime,nbytes) + imidi(numchan) = imidi(numchan)+nbytes+1 + do 1 i = 1 , nbytes + mmidi(numchan,imidi(numchan)-i) = mod(idur,256) + idur = ishft(idur,-8) +1 continue + mmidi(numchan,imidi(numchan)) = 255 + if (typeq .eq. 't') then +c +c Tempo event. in1 = quarters per minute (integer) +c + mmidi(numchan,imidi(numchan)+1) = 5*16+1 + mmidi(numchan,imidi(numchan)+2) = 3 + misperq = nint(60000000./in1) + do 2 i = 1 , 3 + mmidi(numchan,imidi(numchan)+6-i) = mod(misperq,256) + misperq = ishft(misperq,-8) +2 continue + imidi(numchan) = imidi(numchan)+5 + else if (typeq .eq. 'm') then +c +c Meter event. in1=numerator, in2=denom (power of 2) +c + mmidi(numchan,imidi(numchan)+1) = 5*16+8 + mmidi(numchan,imidi(numchan)+2) = 4 + mmidi(numchan,imidi(numchan)+3) = in1 + if (in2 .gt. 0) then + mmidi(numchan,imidi(numchan)+4) = log2(in2) + else + mmidi(numchan,imidi(numchan)+4) = 0 + end if + mmidi(numchan,imidi(numchan)+5) = 24 + mmidi(numchan,imidi(numchan)+6) = 8 + imidi(numchan) = imidi(numchan)+6 + else if (typeq .eq. 'k') then +c +c Keychange event. in1 = isig +c + mmidi(numchan,imidi(numchan)+1) = 5*16+9 + mmidi(numchan,imidi(numchan)+2) = 2 + mmidi(numchan,imidi(numchan)+3) = mod(256+in1,256) + mmidi(numchan,imidi(numchan)+4) = 0 + imidi(numchan) = imidi(numchan)+4 + else + print*,'Program flameout in midievent' + call stop1() + end if + lasttime = miditime + return + end + subroutine moveln(iuin,iuout,done) + logical done + character*129 outq + done = .false. + read(iuin,'(a)',end=1) outq + lenout = llen(outq,129) + write(iuout,'(a)') outq(1:lenout) + return +1 done = .true. + return + end + subroutine mrec1(lineq,iccount,ndxm) +c +c This is called when (a) macro recording is just starting and +c (b) at the start of a new line, if recording is on +c + parameter (maxblks=4000) + character*128 lineq,lnholdq + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + if (.not.mrecord) then +c +c Starting the macro +c + ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount + il1mac(macnum) = ilbuf-1 + ic1mac(macnum) = iccount + mrecord = .true. + end if + if (iccount .lt. 128) then + ndxm = index(lineq(iccount+1:128),'M') + if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M', + * 128-iccount) + if (ndxm .gt. 0) then +c +c This line ends the macro. +c + ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm + il2mac(macnum) = ilbuf-1 + mrecord = .false. + end if + end if + return + end + function ncmid(iv,ip) + parameter (nm=24) + common /all/ mult(nm,200),jv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtol/ tol + if (ncc(iv) .eq. 1) then + ncmid = ncmidcc(iv,1) + else + xtime = to(ipl2(ivx,ip)) + do 1 icc = ncc(iv) , 1 , -1 + if (xtime .gt. tcc(iv,icc)-tol) then + ncmid = ncmidcc(iv,icc) + return + end if +1 continue + print*,'Problem in ncmid()' + stop + end if + end + function ncmidf(clefq) +c +c Return middle line of a clef +c + character*1 clefq +c if (clefq.eq.'t' .or. clefq.eq.'0') then +c ncmidf = 35 +c else if (clefq.eq.'s' .or. clefq.eq.'1') then +c ncmidf = 33 +c else if (clefq.eq.'m' .or. clefq.eq.'2') then +c ncmidf = 31 +c else if (clefq.eq.'a' .or. clefq.eq.'3') then +c ncmidf = 29 +c else if (clefq.eq.'n' .or. clefq.eq.'4') then +c ncmidf = 27 +c else if (clefq.eq.'r' .or. clefq.eq.'5') then +c ncmidf = 25 +c else if (clefq.eq.'f' .or. clefq.eq.'7') then +c ncmidf = 37 +c else +c ncmidf = 23 +c end if + ncmidf = 21+index(' b6r5n4a3m2s1t0f7',clefq)/2*2 + return + end + subroutine newvoice(jv,clefq,change) + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + character*1 ulfbq,clefq + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + logical change,autofbon + nvmx(jv) = 1 + ivmx(jv,1) = jv + itsofar(jv) = 0 + nnl(jv) = 0 + nfb(jv) = 0 + if (firstgulp .or. change) then + ncmidcc(jv,1) = ncmidf(clefq) + else + ncmidcc(jv,1) = ncmidcc(jv,ncc(jv)) + end if + tcc(jv,1) = 0. + ncc(jv) = 1 + nudoff(jv) = 0 + ndotmv(jv) = 0 + do 5 j = 1 , 200 + irest(jv,j) = 0 + islur(jv,j) = 0 + ipl(jv,j) = 0 + nacc(jv,j) = 0 + iornq(jv,j) = 0 + mult(jv,j) = 0 + if (jv.le.2) isfig(jv,j) = .false. +5 continue + return + end + subroutine notefq(noteq,lnote,nolev,ncmid) +c +c Returns name of note level with octave transpositions, updates noctup. +c + common /comoct/ noctup + character*8 noteq + character*1 upcaseq,noteqt,chax + nupfroma = mod(nolev+1,7) + iname = 97+nupfroma + ioctup = (nolev+1)/7-4 + noteqt = chax(iname) + if (ncmid .eq. 23) noteqt = upcaseq(noteqt) + if (ioctup .eq. noctup) then + noteq = noteqt + lnote = 1 +c +c Must ALWAYS check if lnote=1 for use with functions requiring a blank +c + else if (ioctup .gt. noctup) then +c +c Raise octave. Encase in {} +c + write(noteq,'(8a1)')'{',(chax(39),i=noctup,ioctup-1), + * noteqt,'}' + lnote = 3+ioctup-noctup + noctup = ioctup + else +c +c Lower octave +c + write(noteq,'(8a1)')'{',(chax(96),i=ioctup,noctup-1), + * noteqt,'}' + lnote = 3+noctup-ioctup + noctup = ioctup + end if + return + end + subroutine notex(notexq,lnote) +c +c Returns non-beamed full note name +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk, + * isfig,ispoi,btest,even + character*1 udq,udqq,chax + character*4 dotq + character*2 numq + character*79 notexq + character*8 noteq + character*40 restq + common /compoi/ ispoi + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + character*10 figq + ip = ipo(jn) + nole = nolev(ivx,ip) +c +c Check for special situations with 2nds (see precrd) +c + if (btest(nacc(ivx,ip),30)) then + nole = nole - 1 + else if (btest(nacc(ivx,ip),31)) then + nole = nole + 1 + end if + nodu = nodur(ivx,ip) + if (.not.btest(irest(ivx,ip),0)) then + udq = udqq(nole,ncmid(iv,ip), + * islur(ivx,ip),nvmx(iv),ivx,nv) + end if +c +c Check figure level +c +c if (figbass .and. isfig(ivx,ip) +c * .and. .not.btest(irest(ivx,ip),0)) then + if (figbass .and. .not.btest(irest(ivx,ip),0) .and. + * ((ivx.eq.1.and.isfig(1,ip)) + * .or.(ivx.eq.ivxfig2.and.isfig(2,ip)))) then + if (udq .eq. 'u' .or. nodu.ge.64) then +c +c Upper or no stem, fnole (in noleunits) set by notehead +c + fnole = nole + else +c +c Lower stem, fnole set by bottom of stem +c + fnole = nole-stemlen + end if + zmin = fnole-ncmid(ivx,ip)+4 + if (ivx .eq. 1) then + ifigdr(1,iline) = max(ifigdr(1,iline),nint(4-zmin)) + else + ifigdr(2,iline) = max(ifigdr(2,iline),nint(4-zmin)) + end if + end if + if (.not.btest(irest(ivx,ip),0)) then + call notefq(noteq,lnoten,nole,ncmid(iv,ip)) + if (lnoten .eq. 1) call addblank(noteq,lnoten) + if (nodu .eq. 1) then + notexq =sq//'cccc'//udq//noteq(1:lnoten) + lnote = lnoten+6 + else if (nodu .eq. 2) then + notexq =sq//'ccc'//udq//noteq(1:lnoten) + lnote = lnoten+5 + else if (nodu .eq. 4) then + notexq =sq//'cc'//udq//noteq(1:lnoten) + lnote = lnoten+4 + else if (nodu .eq. 8) then + notexq =sq//'c'//udq//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 16) then + notexq =sq//'q'//udq//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 32) then + notexq =sq//'h'//udq//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 64) then + notexq =sq//'wh'//noteq(1:lnoten) + lnote = lnoten+3 + else if (nodu .eq. 128) then +c notexq =sq//'zbreve'//noteq(1:lnoten)//sq//'sk' +c lnote = lnoten+10 + notexq =sq//'breve'//noteq(1:lnoten) + lnote = lnoten+6 + else + dotq = 'p' + ldot = 1 + if (btest(iornq(ivx,ip),13)) then +c +c Dotted note with ')' ornament +c + dotq='m' + else if (btest(islur(ivx,ip),3)) then +c +c Double dot +c + dotq = 'pp' + ldot = 2 + end if + if (nodu .ge. 192) then + notexq =sq//'breve'//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+6+ldot + else if (nodu .ge. 96) then + notexq =sq//'wh'//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 48) then + notexq =sq//'h'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 24) then + notexq =sq//'q'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 12) then + notexq =sq//'c'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+3+ldot + else if (nodu .ge. 6) then + notexq =sq//'cc'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+4+ldot + ispoi = .true. + else + notexq =sq//'ccc'//udq//dotq(1:ldot)//noteq(1:lnoten) + lnote = lnoten+5+ldot + ispoi = .true. + end if + if (dotq(1:1) .eq. 'm') then +c +c Need another call to the note, in case the first one has octave shifts +c + if (lnoten .eq. 2) then + notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}' + lnote = lnote+3 + else + notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1) + lnote = lnote+1 + end if + end if + end if + else if (btest(islur(ivx,ip),29)) then +c +c Blank rest +c + notexq = sq//'sk' + lnote = 3 + else +c +c Non-blank rest +c + lnote = 0 + nole = mod(nole+20,100)-20 +c +c Kluge to get pause symbol for rp: +c + if (btest(islur(ivx,ip),19)) nodu = 64 + if (nodu .le. 28) then +c +c Normal rest < or = double-dotted quarter +c + lrest = 3 + if (nodu .gt. 14) then + restq =sq//'qp' + else if (nodu .gt. 7) then + restq =sq//'ds' + else if (nodu .gt. 3) then + restq =sq//'qs' + else if (nodu .gt. 1) then + restq =sq//'hs' + else + restq =sq//'qqs' + lrest = 4 + end if +c if (2**log2(nodu) .ne. nodu) then +cc +cc One or two dots on rest +cc +c restq = restq(1:3)//'p' +c lrest = 4 +c if (2*nodu .gt. 3*2**log2(nodu)) then +cc +cc Double dotted rest +cc +c restq = restq(1:4)//'p' +c lrest = 5 +c end if +c end if + notexq = restq + lnote = lrest +c +c At this point notexq=restq,lnote=lrest are name of rest. Now raise if necc. +c + if (nole .ne. 0) then + if (abs(nole) .lt. 10) then + noteq = chax(48+abs(nole)) + lnoten = 1 + else + write(noteq(1:2),'(i2)')abs(nole) + lnoten = 2 + end if + if (nole .gt. 0) then + notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote' + else + notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote' + end if + lnote = 16+lnoten +c if (2**log2(nodu) .ne. nodu) then +cc +cc Have dot in raised rest. must put in hbox! +cc +c notexq = notexq(1:lnote)//sq//'hbox{' +c lnote = lnote+6 +c end if + notexq = notexq(1:lnote)//restq(1:lrest) + lnote = lnote+lrest +c if (2**log2(nodu) .ne. nodu) then +c notexq = notexq(1:lnote)//'}' +c lnote = lnote+1 +c end if + end if + if (2**log2(nodu) .ne. nodu) then +c +c Deal with dots (on rests shorter than half rest) +c + restq = sq//'pt' + lrest = 3 + if (2*nodu .gt. 3*2**log2(nodu)) then + restq = sq//'ppt' + lrest = 4 + end if + nole = nole+4 + raisedot = 0 +c +c Tweak dot positions for special cases +c + even = (mod(100+nole,2).eq.0) +c if (.not.even.and.nodu.gt.8.and. +c * (nole.lt.0.or.nole.gt.8)) then + if (.not.even .and. (nole.lt.0.or.nole.gt.8)) then + raisedot = 1 + end if + if (nole.ge.10 .or. nole.le.-1) then + write(numq,'(i2)')nole + restq = restq(1:lrest)//'{'//numq//'}' + lrest = lrest+4 + else + restq = restq(1:lrest)//chax(nole+48) + lrest = lrest+1 + end if + if (raisedot.gt.0) then + restq = sq//'raise'//sq//'internote'// + * sq//'hbox{'//restq(1:lrest)//'}' + lrest = lrest+23 + end if + + + + notexq = restq(1:lrest)//notexq(1:lnote) + lnote = lnote+lrest + end if + else +c +c Half rest or longer +c + if (nole .eq. 0) then +c +c Half or longer rest is not raised or lowered +c + if (nodu .le. 56) then + notexq =sq//'hpause' + lnote = 7 + else if (nodu .le. 112) then + if (.not.btest(islur(ivx,ip),19) .or. + * btest(irest(ivx,ip),25)) then + notexq = sq//'pause' + else + notexq = sq//'pausc' + end if + lnote = 6 + else + notexq =sq//'PAuse' + lnote = 6 + end if + if (2**log2(nodu) .ne. nodu) then +c +c Dotted rest, hpause or longer +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + if (2*nodu .gt. 3*2**log2(nodu)) then +c +c Double dotted long rest +c + notexq = notexq(1:lnote)//'p' + lnote = lnote+1 + end if + end if + else +c +c Raised or lowered half or whole rest +c + if (nodu .eq. 32) then + notexq = sq//'lifthpause' + lnote = 11 + else if (nodu .eq. 48) then + notexq = sq//'lifthpausep' + lnote = 12 + else if (nodu .eq. 56) then + notexq = sq//'lifthpausepp' + lnote = 13 + else if (nodu .eq. 64) then + notexq = sq//'liftpause' + lnote = 10 + else if (nodu .eq. 96) then + notexq = sq//'liftpausep' + lnote = 11 + else if (nodu .eq. 112) then + notexq = sq//'liftpausepp' + lnote = 12 + else if (nodu .eq. 128) then + notexq = sq//'liftPAuse' + lnote = 10 + else +c +c Assume dotted double whole rest +c + notexq = sq//'liftPAusep' + lnote = 11 + end if +c +c Set up height spec +c + nole = sign(abs(nole)/2,nole) + if (nole.le.9 .and. nole.ge.0) then + noteq = chax(48+nole) + lnoten = 1 + else + noteq = '{' + if (nole .ge. -9) then + write(noteq(2:3),'(i2)')nole + lnoten = 3 + else + write(noteq(2:4),'(i3)')nole + lnoten = 4 + end if + noteq = noteq(1:lnoten)//'}' + lnoten = lnoten+1 + end if + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + end if + end if + end if + return + end + function ntindex(line,s2q,lenline) +c +c Returns index(line,s2q) if NOT in TeX string, 0 otherwise +c + character*(*) s2q,line + character*1 chax + logical intex + ndxs2 = index(line,s2q) + ndxbs = index(line,chax(92)) + if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then + ntindex = ndxs2 + else +c +c There are both bs and s2q, and bs is to the left of sq2. So check bs's to +c right of first: End is '\ ', start is ' \' +c + len = lenstr(line,lenline) + intex = .true. + do 1 ic = ndxbs+1 , len + if (ic .eq. ndxs2) then + if (intex) then + ntindex = 0 + ndxs2 = index(line(ic+1:len),s2q)+ic + else + ntindex = ndxs2 + return + end if + else if (intex .and. line(ic+1:ic+2).eq.chax(92)//' ') then + intex = .false. + else if (.not.intex .and. line(ic+1:ic+2).eq.' '//chax(92)) + * then + intex = .true. + end if +1 continue + end if + return + end + subroutine ntrbbb(n,char1q,ulqq,iv,notexq,lnote) +c +c This appends to notexq e.g. '\ibbbu1' +c + common /combbm/ isbbm + logical isbbm + character*79 notexq + character*1 char1q,ulqq,chax + character*4 tempq + if (n .ge. 5) isbbm = .true. + if (lnote .gt. 0) then + notexq = notexq(1:lnote)//chax(92)//char1q + else + notexq = chax(92)//char1q + end if + lnote = lnote+2 + do 3 im = 1 , n + notexq = notexq(1:lnote)//'b' + lnote = lnote+1 +3 continue +c +c add the number, 0 if 12 +c +c 5/25/08 Allow >12 +c +c call istring(mod(iv,12),tempq,len) + if (iv .lt. 24) then + call istring(iv,tempq,len) + else if (iv .eq. 24) then + tempq(1:1) = '0' + len = 1 + else + call printl('Sorry, too man open beams') + call stop1() + end if + notexq = notexq(1:lnote)//ulqq//tempq(1:len) + lnote = lnote+1+len + return + end + function numclef(clefq) +c +c Returns the number to be used as argument of \setclef (for MusiXTeX only) + character*1 clefq +c if (ichar(clefq) .lt. 55) then + if (ichar(clefq) .le. 55) then + numclef = ichar(clefq)-48 + if (numclef .eq. 7) numclef = 9 + else + numclef = index('tsmanrbxxf',clefq)-1 + end if + return + end + subroutine outbar(i,jlast) + character*1 chax + nfmt = log10(i+.5)+2 + if (jlast+5+nfmt .lt. 80) then + write(*,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i + write(15,'(a5,i'//chax(48+nfmt)//',$)')' Bar',i + jlast = jlast+5+nfmt + else + write(*,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i + write(15,'(/,a5,i'//chax(48+nfmt)//',$)')' Bar',i + jlast = 5+nfmt + end if + return + end + subroutine pmxa(basenameq,lbase,isfirst,nsyout,nbarss,optimize) +cccccccccccccccccccccccccccccccccccccccccccccccc +cc cc +cc Subroutine, combine with pmxb.for +cc +cccccccccccccccccccccccccccccccccccccccccccccccc +cc +cc Need to consider X spaces in xtuplets when getting poenom, and +cc maybe fbar? +cc mx06a +cc ID numbers for voices when number of voices is reduced. +cc +cc mx03a +cc account for new fracindent for new movements. +cc +cc Known changes since pmxa. Version 1.1b (see pmxb for longer list) +cc +cc Check ID codes for slurs. +cc Version 1.24 still does not have details for spacing/positioning +cc arpeggios if there are accidentals or shifted notes or crowded scores. +cc Fix problem in 1.22 with arpeggios across multi-line staves +cc Fix problem in 1.22 with flat key signatures +cc Read setup data as strings +cc Warning for octave designation plus +/- +cc Don't pause for volta warning, +cc Macros +cc Correct fsyst to account for transposition and key changes. +cc Check for nbars > nsyst +cc +ccccccccccccccccccccccccccccccccccc + parameter (nm=24,nkb=3999,nks=125,maxblks=4000) + logical loop,usefig,isfirst,optimize + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + integer nn(nm),nodur(nm,200),ivxo(600),ipo(600), + * nnl(nm),itsofar(nm),nib(nm,15),lastbar(0:nks),nbarss(nks) + common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), + * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, + * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) + common /compage/ widthpt,ptheight,hoffpt,voffpt, + * nsyst,nflb,ibarflb(0:40), + * isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18), + * usefig,fintstf,gintstf,fracsys(30),nmovbrk,isysmb(0:30), + * nistaff(0:40) + common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1, + * mbrestsav,kchmid(18),ornrpt,shifton,barend,noinst,stickyS + real*4 elsk(nkb),celsk(0:nkb),elss(nks),to(600),tno(600) + character*128 lnholdq + character*44 basenameq + logical rest(nm,200),firstline,fbon,isvolt,iskchb,kchmid,ornrpt, + * stickyS + common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, + * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 + logical lastchar,newmeter,newmb(nkb),issegno,bottreb,isheadr, + * shifton,barend + common /a1ll/ iv,ivxo,ipo,to,tno,nnl,nv,ibar,mtrnuml, + * nodur,lenbar,iccount,nbars,itsofar,nib,nn, + * rest,lenbr0,lenbr1,firstline,newmeter + common /linecom/ elskb,tnminb(nkb) + common /cblock/ + * etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco, + * xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh + common /cominbot/ inbothd + common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /commus/ musize,whead20 + common /comeon/ eonk,ewmxk + logical mrecord,mplay,endmac,gotclef,cstuplet + logical novshrinktop,upslur,fontslur,WrotePsslurDefaults + common /comnvst/ novshrinktop,cstuplte + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comligfont/ isligfont + logical isligfont + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + logical fulltrans + data wtimesig,wclef,wkeysig + * / 0.72 , 0.8 , 0.28 / + whead20 = 0.3 + if (.not.optimize) then + print* + print*,'Starting first PMX pass' + write(15,'(a)') ' Starting first PMX pass' + end if + if (isfirst) then + open(19,file='pmxaerr.dat') + write(19,'(i6)') 0 + close(19) + end if + if (.not.optimize) jprntb = 81 + macuse = 0 + ornrpt = .false. + stickyS = .false. + mrecord = .false. + mplay = .false. + lastchar = .false. + novshrinktop = .false. + cstuplet = .false. + fontslur = .true. + isligfont = .false. + fulltrans = .false. + do 42 ibarcnt = 1 , nkb + udsp(ibarcnt) = 0. + wminnh(ibarcnt) = -1. +42 continue +c +c Initialize input buffer +c + lenbuf0 = ipbuf + ipbuf = 0 + ilbuf = 1 + call g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp, + * xmtrnum0,newkey(1),npages,nsyst,musize,bottreb) +c +c Set up list of instrument numbers (iv) +c + ivnow = 0 + do 13 instnow = 1 , noinst + do 14 iscount = 1 , nsperi(instnow) + ivnow = ivnow+1 + instno(ivnow) = instnow +14 continue +13 continue +c +c Save initial meter for midi +c + if (.not.isfirst .and. npages.eq.0) then + print*,'Sorry, must have npages>0 for optimization.' + call stop1() + end if + nsyout = nsyst +c +c isig1 will be changed in getnote if there is a transposition +c + isig1 = newkey(1) + if (npages .gt. nsyst) then + call printl('npages > nsyst in input. Please fix the input.') + call stop1() + end if +c +c fbar = afterruleskip/elemskip +c apt = width of small accidental + space in points (= 6 at 20pt) =wheadpt +c + fbar = 1. + wheadpt = whead20*musize + ifig = 0 + usefig = .true. + lenbeat = i1fnodur(mtrdenl,'x') + lenmult = 1 + if (mtrdenl .eq. 2) then + lenbeat = 16 + lenmult = 2 + end if + lenbr1 = lenmult*mtrnuml*lenbeat + lenbr0 = nint(lenmult*xmtrnum0*lenbeat) + mtrnuml = 0 + if (lenbr0 .ne. 0) then + ibaroff = 1 + lenbar = lenbr0 + else + ibaroff = 0 + lenbar = lenbr1 + end if + ibarcnt = 0 + nptr(1) = 1 + iccount = 128 + nmovbrk = 0 + nflb = 0 + nfpb = 0 + ipagfpb(0) = 1 + isysfpb(0) = 1 + ibarflb(0) = 1 + isysflb(0) = 1 + nistaff(0) = nv-1 +c +c Check for pmx.mod +c + linesinpmxmod = 0 +c line1pmxmod = ilbuf + call getpmxmod(.true.,' ') + if (.not.isfirst .and. linesinpmxmod .gt. 0) then + print*,'Sorry, cannot optimize if there is a pmx.mod file' + call stop1() + end if +c +c Initialize for loop over lines +c + nkeys = 1 + ibrkch(1) = 1 + mbrestsav = 0 + shifton = .false. + firstline = .true. + newmeter = .false. + ihead = 0 + isheadr = .false. + gotclef = .false. + idsig = 0 + iddot = 0 + fintstf = -1. + gintstf = 1.0 + listcresc = 0 + listdecresc = 0 +30 loop = .true. + iskchb = .false. + issegno = .false. + nbars = 0 + ibarmbr = 0 +3 do 4 iv = 1 , nv + nvmx(iv) = 1 + ivmx(iv,1) = iv + itsofar(iv) = 0 + nnl(iv) = 0 + do 5 j = 1 , 200 + rest(iv,j) = .false. + nacc(iv,j) = 0. +5 continue +4 continue + iv = 1 + ivx = 1 + fbon = .false. + barend = .false. + isvolt = .false. +2 if (loop) then +c +c Within this short loop, nv voices are filled up for the duration of a block. +c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv) +c nodur(..),rest(..). nnl will later be +c increased and things slid around as accidental skips are added. +c + call g1etnote(loop,ifig,optimize,fulltrans) + if (lastchar) go to 20 + go to 2 + end if + if (mbrestsav .gt. 0) then + call printl(' ') + call printl( + * 'You must enter the same multibar rest in ALL parts') + call stop1() + end if + do 10 ibar = 1 , nbars + ibarcnt = ibarcnt+1 +c +c The following is just a signal to start a new bar when cataloging spaces +c for catspace(...) +c + nptr(ibarcnt+1) = nptr(ibarcnt) + newmb(ibarcnt) = .false. + if (newmeter.and.ibar.eq.1) newmb(ibarcnt) = .true. +c +c Above is only for spacing calcs later on. Remember new meter can only occur +c at START of a new input line (ibar = 1) +c + if (ibar .ne. ibarmbr) then + if (.not.optimize) call outbar(ibarcnt-ibaroff,jprntb) + else + if (.not.optimize) then + write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1 + write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1 + jprntb = 0 + end if + ibaroff = ibaroff-mbrest+1 + end if + if (firstline .and. lenbr0.ne.0) then + if (ibar .eq. 1) then + lenbar = lenbr0 + else + lenbar = lenbr1 + end if + end if + if (ibar .gt. 1) then +c +c For bars after first, slide all stuff down to beginning of arrays +c + do 11 iv = 1 , nv + do 11 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + ioff = nib(ivx,ibar-1) + do 12 ip = 1 , nib(ivx,ibar)-ioff + nodur(ivx,ip) = nodur(ivx,ip+ioff) + rest(ivx,ip) = rest(ivx,ip+ioff) + nacc(ivx,ip) = nacc(ivx,ip+ioff) +12 continue +11 continue + end if + do 67 iv = 1 , nv + do 67 kv = 1 , nvmx(iv) + ioff= 0 + if(ibar.gt.1)ioff = nib(ivmx(iv,kv),ibar-1) +67 continue + call makeabar() + elsk(ibarcnt) = elskb+fbar +10 continue + newmeter = .false. + firstline = .false. + go to 30 +20 continue +c +c Vertical analysis. +c + if (npages .eq. 0) then + if (nsyst .eq. 0) then + print*,'When npages=0, must set nsyst=bars/syst, not 0' + call stop1() + end if + nsyst = (ibarcnt-1)/nsyst+1 + if (nv .eq. 1) then + nsystpp = 12 + else if (nv .eq. 2) then + nsystpp = 7 + else if (nv .eq. 3) then + nsystpp = 5 + else if (nv .eq. 4) then + nsystpp = 3 + else if (nv .le. 7) then + nsystpp = 2 + else + nsystpp = 1 + end if + npages = (nsyst-1)/nsystpp+1 + end if +c +c Check nsyst vs ibarcnt +c + if (nsyst .gt. ibarcnt) then + print* + print*,'nsyst,ibarcnt:',nsyst,ibarcnt + print*,'There are more systems than bars.' + write(15,'(a,2i5)')' nsyst,ibarcnt:',nsyst,ibarcnt + write(15,'(a)')' There are more systems than bars.' + call stop1() + end if +c +c Set up dummy forced line & page breaks after last real one +c + nflb = nflb+1 + ibarflb(nflb) = ibarcnt+1 + isysflb(nflb) = nsyst+1 + nfpb = nfpb+1 + ipagfpb(nfpb) = npages+1 + isysfpb(nfpb) = nsyst+1 + heightil = ptheight*4./musize + open(12,status='SCRATCH') + write(12,'(a)')basenameq(1:lbase) + write(12,*)lbase +c +c Pass to pmxb the initial signature, including effect of transposition. +c + write(12,'(6f10.5/f10.5,3i5)')fbar,wheadpt,etait, + * etatc,etacs1,etatop,etabot,inbothd,inhnoh,isig1 + write(12,*)npages,widthpt,ptheight,hoffpt,voffpt,nsyst + iflbnow = -1 + isysb4 = 0 + do 8 ifpb = 1 , nfpb +c +c Each time thru this loop is like a single score with several pages +c + npages = ipagfpb(ifpb)-ipagfpb(ifpb-1) + nsyst = isysfpb(ifpb)-isysfpb(ifpb-1) + nomnsystp = (nsyst-1)/npages+1 + nshort = nomnsystp*npages-nsyst + do 7 ipage = 1 , npages + nsystp = nomnsystp + if (ipage .le. nshort) nsystp = nsystp-1 +c +c Last system number on this page: + isysendpg = isysb4+nsystp + nintpg = 0 + do 15 isy = isysb4+1, isysendpg + if (isysflb(iflbnow+1) .eq. isy) iflbnow = iflbnow+1 + nintpg = nintpg+nistaff(iflbnow) +15 continue + xilfrac = 0. + xiltxt = 0. + if (ipage.eq.1 .and. ihead.gt.0) then +c +c Needn't zero out ihead after printing titles if we only allow titles at top? +c + if (iand(ihead,1) .eq. 1) then + xiltxt = xiltxt+hgtin*4/musize + xilfrac = xilfrac+etait + end if + if (iand(ihead,2) .eq. 2) then + xiltxt = xiltxt+hgtti*4/musize + xilfrac = xilfrac+etatc + end if + if (iand(ihead,4) .eq. 4) then + xiltxt = xiltxt+hgtco*4/musize + xilfrac = xilfrac+etacs1 + else +c +c Use double the title-composer space if there is no composer +c + xilfrac = xilfrac+etatc + end if + end if + D = xilfrac+nsystp-1+etatop+etabot +c C = nsystp*(nv-1) + C = nintpg +c xN = heightil - xiltxt - 4*nsystp*nv - (nsystp-1)*xilbn + xN = heightil - xiltxt - 4*(nintpg+nsystp) - (nsystp-1)*xilbn + if (bottreb) xN = xN-(nsystp-1)*xilbtc + if (ihead.eq.0 .and. isheadr) xN = xN - xilhdr + if (ifig .eq. 1) then + xN = xN - nsystp*xilfig + end if + glueil = (xN-b*C)/(D+a*C) + omegaG = (b*D+a*xN)/(D+a*C) +c +c G = \interlines between systems +c omega*G = \interlines between staves of the same system +c \interstaff = 4+omega*G +c C = total number of interstaff spaces in the page +c D = omega-indep factors for scalable height = nsy-1 (intersystem glue) +c + etatop + etabot + etatxt + +c N = scaleable height (\interlignes) = height - htext - staff heights - xil +c xil = extra interliges = (nsy-1)*xilbn + 10 if header and no titles +c + (nsy-1)*xiltcb for treble clef bottoms +c + nsy*xilfig for figures +c G = N/(D + omega * C) = glueil, (1) +c But (empirically) omega*G = a*G + b (2) +c with a=1.071 and b=2.714 +c Solving (1) and (2) gives +c G = (N-b*C)/(D+a*C) , omega*G = (b*D+a*N)/(D+a*C) +c Pass to pmxb omega*G (=\interstaff-4) +c (etatop,bot,it,tc,cx)*G as inputs to \titles +c +c glueil = (heightil-xiltxt-nsystp*(xil+4*nv)) +c * /(nsystp*(1+gfact*(nv-1))-1+etatop+etabot+xilfrac) +c xnsttop = glueil*etatop +c xintstaff = 4+gfact*glueil +c +c Only the first page will get local adjustment now if needed, others in pmxb +c + if (ifpb.eq.1 .and. ipage.eq.1 .and. fintstf.gt.0.) then + facins = fintstf + fintstf = -1. + else +c +c gintstf = 1.0 by default, but may be changed with AI<x> +c + facins = gintstf + end if + write(12,*)nsystp,max(0.,etatop*glueil),facins*(omegaG+4) + ihead = 0 + isheadr = .false. + isysb4 = isysendpg +7 continue +8 continue +c +c Done with vertical, now do horizontals +c + celsk(1) = elsk(1) + do 21 ibar = 2 , ibarcnt + celsk(ibar) = celsk(ibar-1)+elsk(ibar) +21 continue + lastbar(0) = 0 + ibar1 = 1 + wmins = -1. + iflb = 1 + imovbrk = 0 + ikey = 1 +c +c Return nsyst to its *total* value +c + nsyst = isysfpb(nfpb)-1 + do 22 isyst = 1 , nsyst + if (isyst .eq. isysflb(iflb)) iflb = iflb+1 + if (nmovbrk.gt.0 .and. imovbrk.lt.nmovbrk) then + if (isyst .eq. isysmb(imovbrk+1)) imovbrk = imovbrk+1 + end if + ibarb4 = lastbar(isyst-1) + if (isyst .eq. 1) then + if (isfirst) elsstarg = celsk(ibarflb(1)-1)/ + * (isysflb(1)-1-fracindent)*(1-fracindent) + celskb4 = 0. + else + celskb4 = celsk(ibarb4) +c +c Must dimension isysmb(0:*) just so I can execute this test! +c + if (isfirst) then + if (nmovbrk.gt.0 .and. isyst.eq.isysmb(imovbrk)) then +c +c First syst after forced line break. There may be indentation. +c + elsstarg = (celsk(ibarflb(iflb)-1)-celskb4) + * /(isysflb(iflb)-isyst-fracsys(imovbrk)) + * *(1-fracsys(imovbrk)) + else +c +c There is no indentation to deal with +c + elsstarg = (celsk(ibarflb(iflb)-1)-celskb4) + * /(isysflb(iflb)-isyst) + end if + end if + end if + if (isfirst) then + diff1 = abs(elsstarg-elsk(ibarb4+1)) + do 23 ibar = ibarb4+2 , ibarcnt + diff = elsstarg-(celsk(ibar)-celskb4) + if (abs(diff) .ge. diff1) go to 24 + diff1 = abs(diff) +23 continue +24 ibar = ibar-1 + lastbar(isyst) = ibar + nbarss(isyst) = ibar-ibarb4 + else +c +c nbarss is given as an input, must compute lastbar and ibar +c + lastbar(isyst) = nbarss(isyst)+ibarb4 + ibar = lastbar(isyst) + end if +c +c elss is # of elemskip in the syst. from notes & ars's, not ruleskips, ask's. +c + elss(isyst) = celsk(ibar)-celskb4 + write(12,'(i5)')lastbar(isyst-1)+1 +c +c Transposed sigs are isig1, newkey(2,3,...). +c + if (ikey .eq. 1) then + key1 = isig1 + else + key1 = newkey(ikey) + end if + fsyst = wclef+abs(key1)*wkeysig+2./musize + xelsk = 0. +1 if (ikey.lt.nkeys) then + if (ibrkch(ikey+1).le.lastbar(isyst)) then +c +c Add space for all key changes +c + ikey = ikey+1 + key2 = newkey(ikey) + naccs = max(abs(key2-key1),max(abs(key1),abs(key2))) + fsyst = fsyst+naccs*wkeysig +c +c Account for afterruleskips (fbar) +c + xelsk = xelsk+fbar/2 + if (ibrkch(ikey).lt.lastbar(isyst) .and. .not.kchmid(ikey)) + * xelsk = xelsk-1. + key1 = key2 + go to 1 + end if + end if +c +c Add extra fixed space for double bar +c + if (isyst .eq. nsyst) then + fsyst = fsyst+4.5/musize + end if +c +c Add extra fixed space for initial time signature +c + if (isyst .eq. 1) then + fsyst = fsyst+wtimesig + end if +c +c Add extra fixed space for time signature changes & user-defined spaces +c + do 26 ibars = ibarb4+1 , lastbar(isyst) + if (newmb(ibars)) fsyst = fsyst+wtimesig + fsyst = fsyst+udsp(ibars)/musize +26 continue + if (isyst .eq. 1) then + wdpt = widthpt*(1-fracindent) + else + if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and. + * isyst.eq.isysmb(imovbrk)) then + wdpt = widthpt*(1-fracsys(imovbrk)) + else + wdpt = widthpt + end if + end if + wsyspt = wdpt-fsyst*musize-0.4*nbarss(isyst) +c +c Checks for min spacing +c Get min allowable space +c + dtmin = 1000. + do 45 ibar = ibar1 , ibar1+nbarss(isyst)-1 + dtmin = min(dtmin,tnminb(ibar)) + if (wminnh(ibar).ge.0.) wmins = wminnh(ibar) +45 continue + if (wmins .lt. 0) wmins = 0.3 + wminpt = (1+wmins)*0.3*musize +c +c Find max duration & # of notes for this system +c + dtmax = 0. + nns = 0 + do 43 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1 + dtmax = max(dtmax,durb(iptr)) + nns = nns + nnpd(iptr) +43 continue + elmin0 = wsyspt*f1eon(dtmin)/(elss(isyst)+xelsk) + if (elmin0 .ge. wminpt) then +c +c Subtract out fbar stuff to keep old way of passing sumelsk to pmxb; +c there is no need to "flatten" +c + sumelsk = elss(isyst)-fbar*nbarss(isyst) + eonk = 0. + ewmxk = 1. + else + elmin1 = wsyspt/((fbar*nbarss(isyst)+xelsk)/f1eon(dtmax)+nns) + if (elmin1 .le. wminpt) then +c print* +c print*,'In system #',isyst,' cannot meet min. space rqmt' +c write(15,'(/a,i5,a)') +c * 'In system #',isyst,' cannot meet min. space rqmt' + eonk = 0.9 + else +c +c Find eonk by Newton method +c +c eonk = min(.9,(wminpt-elmin0)/(elmin1-elmin0)) + call findeonk(nptr(ibar1),nptr(ibar1+nbarss(isyst))-1, + * wsyspt/wminpt,fbar*nbarss(isyst)+xelsk,dtmin,dtmax, + * (wminpt-elmin0)/(elmin1-elmin0)) + eonk = min(.9,eonk) + end if + ewmxk = f1eon(dtmax)**eonk +c +c Recompute poenom! +c + sumelsk = 0 + do 44 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1 + sumelsk = sumelsk + * + nnpd(iptr)*sqzb(iptr)*feon(durb(iptr)/sqzb(iptr)) +44 continue + end if + poenom = wsyspt/(sumelsk+fbar*nbarss(isyst)+xelsk) +c +c Set fracindent for output: orig if isyst=1, fracsys(imovbrk) if movbrk, else 0 +c + if (isyst .gt. 0) then + if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and. + * isyst.eq.isysmb(imovbrk)) then + fracindent = fracsys(imovbrk) + else + fracindent = 0. + end if + end if + write(12,'(1pe12.5/i5,5e12.3)') poenom,nbarss(isyst), + * sumelsk,fsyst,fracindent,eonk,ewmxk + ibar1 = ibar1+nbarss(isyst) +22 continue + rewind(12) + open(13,status='SCRATCH') + write(13,'(i5)')ifig + rewind(13) + ilbuf = 1 + ipbuf = 0 + if (.not.optimize) then + write(*,'(/,a)')' Done with first pass' + print* + write(15,'(/,a)')' Done with first pass' + write(15,'()') + end if +c +c Following syntax is needed since pmxa is called with literal argument .false. +c + if (isfirst) isfirst = .false. + return + end + subroutine pmxb(inlast,poevec,ncalls,optimize) +cccccccccccccccccccccccccc +cc +cc To Do +cc +cc Resolve disagreement in final poe for 1st system, compared with *.mx2 +cc Shift slurs on right- or left-shifted main notes (2/7/99) +cc Various end-of-input-block repeat problems (ick142.pmx). +cc Force multiplicity for un-beamed xtups. +cc Clef change at end of piece +cc Global "A" option to maximize "X" at a given time tick. +cc Tighten test for end-of-bar hardspace, flgndv(ivx) due to right-shifted +cc note. See trubl18.pmx +cc Tab character as space. +cc Clef interference with second line of music. +cc Add space for interferences between *different* lines of music? +cc Shift arpeggios, both automatic and manual. +cc Different musicsize for different instruments. +cc Spacing checks for accid's on left-shifted chord notes +cc Spacing checks for double dots +cc Allow forced line breaks w/o setting nsyst. +cc Cresc-Decresc. (Enhance MusiXTeX first?) +cc Dynamic Marks. +cc Bug with Voltas at line end (MusiXTeX problem?). +cc Subtle bug w/ slur hgt over line brk, see trubl15.pmx +cc Stem-end slurs. +cc Allow units in indentation. +cc Make inline TeX more context sensitive. +cc Werner's 4/2/98 problem with "o?" +cc Scor2prt converts e.g. "r0+0" into "r0 0", which seems to be wrong. +cc converts e.g. "r2db" into "r2d", which might be wrong. +cc Werner's generalsignature problem with Key change and new transposition. +cc (wibug8.pmx) +cc Unequal xtuplets +cc Print both sets of bar #'s in tex file. +cc Make barlines invisible \def\xbar{\empty} , fix fbar. +cc Auto-tie slurs 'At' +cc Forced line break anywhere (e.g. at a mid-bar repeat). +cc Clef change at very start of file. +cc Tighten test for M as macro terminator. +cc Fix title so not separate limit on author length + composer length. +cc Arpeggios in xtups. +cc +cc mx10b +cc Option for instrument name at top center. Last item in P command: +cc P[n]c text is instrument name (use in parts) +cc P[n]cstuff text is stuff (up to 1st blank) +cc P[n]c"stuff with spaces" text is stuff with spaces +cc +cc Post version 1.43 +cc Reduced space rqmt for multiplicity-0 graces (no flag) +cc Removed last sepsym in centered whole-bar rests, fixes volta height bug. +cc +cc Version 1.43 +cc Fix spacing for end-of-line signature change. +cc Adjust left-shift of grace group for shifted accidentals. +cc Put in extra space for left-shifted accidentals. +cc Fix bug with dot-shift before accid-shift on chord note. +cc Space-check for right-shifted main notes. +cc Enable forcing stem direction of single notes in non-beamed xtups. +cc Disallow clef change after last note before end of input block (pmxa) +cc Print meter change before page break +cc increase length of strings for \titles macro +cc version 1.42 +cc Loosen up input syntax for "X" commands. Subroutine getx() +cc "B" and "P" in "X" commands +cc mx09b +cc Allow multiple rests at start of xtup +cc Add 64th rest +cc Fix xtup numbers over rests. (subroutine levrn) +cc Initialize notcrd=.false. every gulp. Avoids undefined state with e.g. +cc c za / ( c a ... +cc Allow double dots to be shifted. +cc Fix spacing with double dotted notes; permit splitting small note. +cc Fix \dotted printout so it works with old compiler +cc mx08b +cc Automatic spaces if needed for shifted accidentals. +cc Some Dynamics +cc Increase accid. horiz. shift resolution to .o5 (use one more bit in nacc) +cc version 1.41 +cc Allow ":" as last char of path name +cc Dotted slurs "sb" +cc Continue bar numbering at movement break "L[integer]Mc" +cc mx07b +cc Whole-bar rests with double lines of music. Fixed all options ? +cc Shift accidentals, either [+|-][integer][+|-][number] or [<|>][number]. +cc Option to suppress centering full-bar rests. "o" +cc mx06b +cc Shift accid on left-shifted chord note. +cc Rest as first note of xtup. +cc Wrong slopes with small widths. Scale slfac1 by widthpt_default/widthpt +cc Allow Rb for single bar at movemnet break or end of piece. (islur(25)) +cc Change # of inst at a movement break. noinst is total # and must be used +cc in 1st movement. ninow is current. nspern(1,...,ninow) is current +cc staves/inst, nsperi(1,...,noinst) is original. rename tells whether to +cc reprint names in parindent at a movement break. Default is .false. +cc unless ninow changes, then .true. But can force either with r+/- as +cc option in 'M' +cc mx04b +cc Double-dotted notes, separate+beamed, main+chord, still no extra space. +cc ??? Don't shift slur ends on whole notes. +cc (pmxa) Write line number of error in pmxaerr.dat +cc mx02b +cc Admit "RD" before "/" (search for "rptfq2:" ) +cc In doslur, for multi-line staves, single notes, check forced stem dir'n +cc before setting stemup (used to set horiz offset). +ccccccccccccccccccccccccccccccc + parameter (nm=24,nks=125,mv=24576,maxblks=4000) +c +c FYI /all/ differs in appearance in function ncmid +c + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) +ccccccccccccc +cc islur cc +ccccccccccccc +c bit meaning +c 0 slur activity on this note +c 1 t-slur here. +c 2 force 0-slope beam starting on this note +c 3 Double dotted note! +c 4 grace before main note +c 5 left repeat +c 6 right repeat +c 7 start Volta +c 8 doublebar +c 9 end Volta +c 10 on=>endvoltabox +c 11 on=>clefchange +c 12-14 0=>treble, ... , 6=>bass +c 15 on=> start new block for clef change (maybe diff. voice) +c 16 literal TeX string +c 17 1=up, 0=down stem for single note (override) See bit 30! +c 18 if on, prohibit beaming +c 19 if on, full bar rest as pause +c 20 Beam multiplicity down-up +c 21 Forced multiplicity for any beam including xtups +c 22-24 Value of forced multiplicity +c 25 single barline at movement break +c 26 doubleBAR (see bits 5,6,8) +c 27-28 Forced beam fine-tune height (1 to 3) +c 29 Blank rest +c 30 If on, get stem dir'n from bit 17 +c 31 If on, suppress printing number with xtuplet starting here +ccccccccccccc +cc ipl cc +ccccccccccccc +cc 0-7 Location in list [0,200] +c 0-7 Unused +c 8 left offset main note one headwidth +c 9 right offset main note one headwidth +c 10 chord present? +c 11-16 Forced beam height adjustment (-30 to +30) +c 17-22 Forced beam slope adjustment (-30 to +30) +c 23-26 Slur index for Way-after grace. Inserted when slur is started. +cc 27 Unused? +c 27 5th bit for slur index for Way-after grace (100712) +c 28 key change: only in voice 1 +c 29 Grace after main note. (Type A) +c 30 In forced beam. Signals need to check beam heights +c 31 Grace way after main note. (stretch to next note, type W) +ccccccccccccc +cc iornq cc +ccccccccccccc +c 0 Ornament "(". Was user-defined horizontal slur shift on this note +c until 9/24/97; changed that to irest(21) +c 1-13 stmgx+Tupf._) +c 14 Down fermata, was F +c 15 Trill w/o "tr", was U +c 16-18 Editorial s,f,n +c 19-20 >^ +c 21 "?" for editorial accid, w/ or w/o s,f,n +c 22 Set if ihornb governs ornament height. Same in icrdorn. +c 23 Set in getorn if ANY note at time of this main note has ornament. +c This is ONLY used in beamstrt to signal whether to do more +c tests for whether ihornb is needed. (ihornb is only needed +c if nonchord+upbm, chord+upbm+top_note, chord+dnbm+bot_note) +c (7/1/00)Also set if any dynamic, as ihornb will be needed when dnbm. +c 24 Slur on after or way-after grace. Use as signal to START slur. +c 25 Tweak orn ht. Same in icrdorn for chord note +c 26 Insert user-defined space before this note (was 22) +c 27 Arpeggio stop or start (if 2 at same time), or all-in-this-chord +c 28 caesura or breath +c 29 blank barline (must be iv=1) (would have used islur but no room) +c 30 "Look-left" option for keyboard rest +c 31 Set if any note (main or chord) has cautionary accid, for space checks +ccccccccccccc +cc irest cc +ccccccccccccc +c 0 rest=1, no rest = 0 +c 1 There will be a vertical shift for number of this xtup +c 2-6 Height shift, 1 => -15, 31 => +15 Indicate by +/- [n] after 'n' +c 7 There is a horizontal shift for xtup number +c 9-13 Horiz shift, 1=>-1.5, ... , 31=>+1.5 +c 14 Flip up/down-ness of xtup number +c 15 Single-voice, single note shift X(...)[p]S +c 16 Start single-voice, multinote shift with this note X(...)[p]: +c 17 End single-voice, multinote shift after this note. Enter symbol +c after note. X: +c 18 User-defined hardspace after last note of bar, *after* this note. +c Value still stored in udoff(ivx,nudoff(ivx)), not with other +c hardspaces in udsp, to avoid confusion with time checks. +c 19 Move the dot. Data stored in ndotmv,updot,rtdot +c 20 Set if right-shifted main or chord note here. Use for space checks. +c 21 User-defined hardspace in xtup +c 22 User-defined slur shift horizontal slur shift. +c 23 Set on last note before staff-jumping a beam. +c 24 Set on first note after staff-jumping a beam +c 25 Suppress rest centering. "ro" +c 26 Dynamic on this note +c 27 Set if left-shifted main or chord note here. Use for space checks. +c 28 Set if xtup starts on this note. +c 29 Set on lowest-voice note at same time as 1st note after jump-beam. +c 30 Set on note after end of jump-beam segment, to force new note group +c 31 Flag for cautionary accidental +ccccccccccccc +cc nacc cc +ccccccccccccc +c 0-1 0=no accid, 1=fl, 2=sh, 3=na +c 2 double +c 3 big +c 4-9 vertshift-32 +c 10-16 20*(horiz. shift + 5.35) (Recentered ver 2.32) +c 17 Midi-only accidental +c 18 2:1 xtup +c 19 Together with nacc(18), increase multiplicity by 1 and dot 1st note. +c 20 Set on last note of each seg except last seg of single-slope beam. +c 21 Set on 1st note of each seg except 1st seg of single-slope beam. +c 22-26 If .ne.0, printed xtup number for xtup starting on this note. +c 27 Set for dotted xtup note. Mult dur by 1.5, mult next by .5 & increase +c multiplicity by 1 +c 28 Set on main note of chord if accidentals are ordered. +c 29 Tag for chordal accidental shift...means add to autoshifts. +c 30-31 Set 30|31 if main note in a chord is part of a 2nd and needs to be shifted. +c If upstem|downstem, main is upper|lower member of 2nd +c Action is to interchange pitches only when notes are placed. +ccccccccccccc +cc mult cc +ccccccccccccc +c 0-3 Multiplicity+8 (mult= # of flags) +c 4 Set if slope adjustment for xtup bracket +c 5-9 16+slope adjustment +c 27 Stemlength override +c 28-30 New stem length. +ccccccccccccc +cc isdat1 cc +ccccccccccccc +c 13-17 iv +c 3-10 ip +c 11 start/stop switch +c 12 kv-1 +c 19-25 ichar(code$) +c 26 force direction? +c 27 forced dir'n = up if on, set in sslur; also +c final direction, set in doslur when beam is started, used on term. +c 28-31 ndxslur, set in doslur when beam is started, used on term. +ccccccccccccc +cc isdat2 cc +ccccccccccccc +c 0 Chord switch. Not set on main note. +c 1-2 left/right notehead shift. Set only for chord note. +c 3 tie positioning +c 4 dotted slur +c 6-11 voff1 1-63 => -31...+31 +c 12-18 hoff1 1-127 => -6.3...+6.3 +c 19-25 nolev +c 26 \sluradjust (p+s) +c 27 \nosluradjust (p-s) +c 28 \tieadjust (p+t) +c 29 \notieadjust (p-t) +ccccccccccccc +cc isdat3 cc +ccccccccccccc +c 0 set if midslur (at least one argument) +c 1 set if curve (2 more args) +c 2-7 32+first arg (height correction) (1st arg may be negative) +c 8-10 second arg (initial slope) +c 11-13 third arg (closing slope) +c 14-21 tie level for use in LineBreakTies +c 22-29 ncm for use in LineBreakTies +ccccccccccccc +cc isdat4 cc Set these all at turn-on using s option +ccccccccccccc +c 0-5 Linebreak seg 1 voff 1-63 => -31...+31 +c 6-12 Linebreak seg 1 hoff 1-127 => -6.3...+6.3 +c 16-21 Linebreak seg 2 voff 1-63 => -31...+31 +c 22-28 Linebreak seg 2 hoff 1-127 => -6.3...+6.3 +ccccccccccccc +c icrdat c +ccccccccccccc +c 0-7 ip within voice +c 8-11 ivx (together with 28th bit) +c 12-18 note level +c 19 accidental? +c 20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp) +c 23 shift left +c 24 shift right +c 25 arpeggio start or stop +c 26 flag for moved dot (here, not icrdot, since this is always reset!) +c 27 Midi-only accidental +c 28 (6/27/10) 5th bit for ivx, to allow up to 24 voices +c 29 Tag for accidental shift...means add to autoshifts. +c 31 Flag for cautionary accidental on chord note +ccccccccccccc +c icrdot c: +ccccccccccccc +c 0-6 10*abs(vertical dot shift in \internote) + 64 +c 7-13 10*abs(horizontal dot shift in \internote) + 64 +c 14-19 vert accidental shift-32 +c 20-26 20*(horiz accidental shift+3.2) +c 27-29 top-down level rank of chord note w/accid. Set in crdaccs. +c +c Bits in icrdorn are same as in iornq, even tho most orns won't go in crds. +c +cccccccccccccccccccccccccccccccc + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + character*10 figq + character*1 ulq,sepsymq,sq,chax + logical beamon,firstgulp,figbass,figchk, + * isfig,rptnd1,rptprev + logical loop,lastchar,slint,svolta,evolta,onvolt, + * cwrest(nm),islast,inlast,optimize + integer istop(80),numbms(nm),istart(80) + real*4 xnsttop(40),xintstaff(40),hesk(23),hpts(23),poevec(nks), + * tstart(80),squez(80) + character*1 clefq(nm),ulfbq,rptfq1,rptfq2,charq + character*79 notexq,inameq + character*40 pathnameq + character*44 basenameq + character*24 fmtq + character*20 voltxtq + character*120 instrq,titleq,compoq + common /comlast/ islast,usevshrink + logical usevshrink,stickyS,OptLineBreakTies,autofbon + common /combjmp/ ivbj1,ivbj2,isbjmp,isbj2 + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /cominbot/ inbothd + common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + common /comnsp/ space(80),nb,prevtn(nm), + * flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm) + common /comstart/ facmtr + common /comfb/ nfb(nm),t1fb(nm,40),t2fb(nm,40),ulfbq(nm,40),ifb, + * tautofb,autofbon,t1autofb + common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,stickyS, + * movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf, + * rptprev,equalize,rptfq1,rptfq2 + common /combeam/ ibmtyp + common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd, + * npreslur,was2(nm),ninow,nobar1,nsystp(40),ipage, + * OptLineBreakTies,HeaderSpecial + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comas2/ nasksys,wasksys(800),elasksys(800) + common /comas3/ ask(2500),iask,topmods + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + common /comsln/ is1n1,is2n1,irzbnd,isnx + common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(2,74),aftshft, + * nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr, + * noffseg,ngrace,nvolt,ivlit(83),iplit(83),nlit, + * graspace(37), + * lenlit(83),multg(37),upg(37),slurg(37),slashg(37), + * naccg(74),voltxtq(6),litq(83) + logical upg,slurg,slashg,fbon,ornrpt,shifton,isbjmp,notcrd,was2, + * isbj2,fontslur,WrotePsslurDefaults,HeaderSpecial + common /comivxudorn/ivxudorn(63) + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + character*128 litq,lnholdq + logical upslur,bar1syst,vshrink,lrpt,rrpt,lrptpend, + * ispoi,bcspec,topmods,headlog,clchb,clchv(nm),flgndb, + * btest,sluron,setis,nobar1 + common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), + * ndotmv(nm),updot(nm,20),rtdot(nm,20) + common /compoi/ ispoi + common /combc/ bcspec + common /comeon/ eonk,ewmxk + common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac, + * flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac, + * rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, + * rtshfac + common /comhsp/ hpttot(176) + common /combmh/ bmhgt,clefend + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + common /strtmid/ ihnum3,flipend(nm),ixrest(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + common /commus/ musize,whead20 + common /comtol/ tol + common /comdyn/ ndyn,idyndat(99),levdsav(nm),ivowg(12),hoh1(12), + * hoh2(12),hoh2h1(2),ntxtdyn,ivxiptxt(41),txtdynq(41), + * idynda2(99),levhssav(nm),listcresc,listdecresc + character*128 txtdynq + logical mrecord,mplay,endmac,flipend,istype0,lowdot,rename,ispstie + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc,equalize, + * ismbr,putmbr + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /comcb/ nbc,ibcdata(36) + common /comclefq/ clefq + common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), + * ArpShift(20) + common /comligfont/ isligfont + logical isligfont + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + common /combibarcnt/ ibarcnt + character*40 nmq + if (.not.optimize) then + print* + print*,'Starting second PMX pass' + print* + write(15,'(a)')'Starting second PMX pass' + end if + ncalls = ncalls+1 + islast = inlast + macuse = 0 + isyscnt = 0 + stemmax = 8.2 + stemmin = 3.9 + stemlen = 6.0 + sq = chax(92) + bcspec = .true. + topmods = .false. + ismbr = .false. + read(12,'(a)')basenameq + read(12,*)lbase + read(12,*)fbar,wheadpt,etait,etatc,etacs1,etatop, + * etabot,inbothd,inhnoh,isig + ilbuf = 1 + ipbuf = 0 + call getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0, + * npages,nsyst,musicsize,fracindent,istype0,inameq, + * clefq,sepsymq,pathnameq,lpath,isig0) + if (ismidi) then +c +c Initial key signature and meter for pickup bar +c + call midievent('k',isig,0) + if (xmtrnum0 .gt. tol) then +c +c We have a pickup. Some tricky stuff to get a meter: +c + xntrial = xmtrnum0 + do 5 ip2 = 0 , 5 + if (abs(mod(xntrial,1.)) .lt. tol) go to 6 + xntrial = xntrial*2 +5 continue + print*,'Problem finding meter for pickup bar' + xntrial = 1. + ip2 = 0 +6 continue + call midievent('m',nint(xntrial),2**ip2*mtrdenl) + else +c +c No pickup, enter the starting meter +c + call midievent('m',mtrnuml,mtrdenl) + end if + end if +c +c Set musicsize from value passed in common, due to possible reset by S[n]m16 +c + musicsize = musize + read(12,*)npages,widthpt,height,hoffpt,voffpt,nsyst, + * (nsystp(ipa),xnsttop(ipa),xintstaff(ipa),ipa=1,npages),iauto +c +c If default width ever changes, must adjust this stmt. +c + slfac1 = 0.00569*524./widthpt + figbass = .false. + read(13,*)ifig + if (ifig .eq. 1) then + figbass = .true. + open(14,status='SCRATCH') + write(14,'(a)')sq//'def'//sq//'fixdrop{'//sq//'advance'//sq// + * 'sysno by 1'//sq//'ifcase'//sq//'sysno%' + end if + lastchar = .false. + ibcoff = 0 + if (xmtrnum0 .gt. 0.) ibcoff = -1 + open(11,status='SCRATCH') +c +c vshrink for the first page is calculated in topfile, +c and if true set interstaff=10. vshrink affects Titles. +c Must also save vshrink for page ending. +c + call topfile(basenameq,lbase,nv,clefq,noinst,musicsize, + * xintstaff(1),mtrnmp,mtrdnp,vshrink,fbar,fontslur) +c +c ninow is working value of # of instruments. noinst is max #, and # at start. +c + ninow = noinst +c +c Save original printed meter in case movement breaks +c + movnmp = mtrnmp + movdnp = mtrdnp +c + if (islast .and. figbass .and. musicsize.eq.16) + * write(11,'(a)')sq//'def'//sq//'figfont{'//sq//'eightrm}%' +c + if (islast .and. isligfont) then + if (musicsize .eq. 16) then + write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 8pt%' + else + write(11,'(a)')sq//'font'//sq//'ligfont=cmrj at 10pt%' + end if + end if + lenbeat = ifnodur(mtrdenl,'x') + if (mtrdenl .eq. 2) lenbeat = 16 + lenb1 = mtrnuml*lenbeat + if (mtrdenl .eq. 2) lenb1 = lenb1*2 + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + lenb0 = nint(xmtrnum0*lenbeat) + if (mtrdenl .eq. 2) lenb0 = lenb0*2 + if (lenb0 .ne. 0) then + if (islast) write(11,'(a)')sq//'advance'//sq//'barno by -1' + lenbar = lenb0 + else + lenbar = lenb1 + end if +c +c Initialize full-program variables +c + fixednew = 0. + scaldold = 0. + fintstf = -1. + gintstf = 1. + nasksys = 0 + ibarcnt = 0 + iline = 0 + movbrk = 0 + isystpg = 0 + ipage = 1 + iccount = 128 + iask = 0 + nhstot = 0 + nb = 1 + if (.not.optimize) jprntb = 81 + idsig = 0 +c +c Next 5 are raise-barno parameters. irzbnd is integer part of default level. +c + irzbnd = 3 + if (isig.eq.3 .and. clefq(nv).eq.'t') irzbnd = 4 + is1n1 = 0 + isnx = 0 + SlurCurve = 0. +c +c 111109 Made global rather than per gulp +c + ndyn = 0 + ispoi = .false. + slint = .false. + lrptpend = .false. + rptnd1 = .false. + rptfq2 = 'E' + rptprev = .false. + onvolt = .false. + flgndb = .false. + fbon = .false. + shifton = .false. + ornrpt = .false. + setis = .false. + lowdot = .false. + rename = .false. + nobar1 = .false. + equalize = .false. + usevshrink = .true. + WrotePsslurDefaults = .false. + OptLineBreakTies = .false. + HeaderSpecial = .false. +c +c vshrink is initialized in topfile +c + stickyS = .false. +c +c ixrest = 1 or 2 if xtup has started with a rest +c + do 1 ivx = 1 , nm + ixrest(ivx) = 0 + fullsize(ivx) = 1. +c +c Set legacy note level to middle c as default +c + ndlev(ivx,1) = 29 + ndlev(ivx,2) = 29 +1 continue + npreslur = 0 + nhssys = 0 + listslur = 0 + do 31 i = 1 , 202 + isdat1(i) = 0 + isdat2(i) = 0 +31 continue + nsdat = 0 +c +c Initialize flag for figures in any other voice than 1 +c + ivxfig2 = 0 +c +c Initialize for loop over gulps +c + firstgulp = .true. +c +c Start a gulp +c +30 loop = .true. + notcrd = .true. + isbjmp = .false. + isbj2 = .false. + autofbon = .false. + tautofb = 0. + nbars = 0 + nfigs(1) = 0 + nfigs(2) = 0 + ngrace = 0 + ntrill = 0 + ncrd = 0 + nudorn = 0 + nlit = 0 + nvolt = 0 + ibarmbr = 0 + nudsp = 0 +c ndyn = 0 ! 111109 + ntxtdyn = 0 + nbc = 0 + NumArpShift = 0 + do 3 i = 1 , 37 + graspace(i) = 0. +3 continue +c +c Now initialize up to nv. Do it in getnote as r'qd for 2nd voices per syst. +c and also if nv increases in an 'M' directive. +c + do 4 iv = 1 , nv + call newvoice(iv,clefq(iv),.false.) +4 continue +c +c Check if endsymbol was set earlier +c + if (rptnd1) then + rptnd1 = .false. + rptfq2 = rptfq1 + else +c +c Only use if movbrk>0, to signal default ('RD') +c + rptfq2 = 'E' + end if + iv = 1 + ivx = 1 +2 if (loop) then +c +c Within this loop, nv voices are filled up for the duration of the block. +c On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv) +c nolev(nv,nnl(nv)),nodur(..),accq(..),irest(..). +c nbars is for this input block. +c Only at the beginning of an input block will there be a possible mtr change, +c signalled by a nonzero mtrnuml. (which will be re-zeroed right after change) +c + call getnote(loop) + if (lastchar) go to 40 + go to 2 + end if +c +c Finished an input block (gulp). +c + if (ismidi) then +c +c Put rests into midi array for 2nd lines that were not used in this gulp. +c + do 60 iv = 1 , nv + if (twoline(iv) .and. nvmx(iv).eq.1) then + if (firstgulp .and. lenb0.ne.0) then + call addmidi(midchan(iv,2),0,0,0, + * (nbars-1.)*lenbar+lenb0,.true.,.false.) + else + call addmidi(midchan(iv,2),0,0,0,1.*nbars*lenbar,.true., + * .false.) + end if + end if +60 continue + end if + nvolt = 0 + do 28 iv = 1 , nm + nudoff(iv) = 0 + ndotmv(iv) = 0 +28 continue +c +c Put stuff at top of p.1. Must wait until now to have read title info. +c + if (ibarcnt .eq. 0) then + call puttitle(inhnoh,xnsttop(ipage), + * etatop,sq,etait,etatc,etacs1,nv,vshrink,sepsymq) + if (HeaderSpecial) +c +c Write special header for first page +c + * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%' + end if + do 10 ibar = 1 , nbars + ibarcnt = ibarcnt+1 + bar1syst = ibarcnt .eq. iauto + ndig = max(0,int(log10(.001+ibarcnt+ibcoff))) + if (islast) + * write(11,'(a11,i'//chax(50+ndig)//')') + * '% Bar count',ibarcnt+ibcoff + if (ibar .ne. ibarmbr) then + if (.not.optimize) call outbar(ibarcnt+ibcoff,jprntb) + else + if (.not.optimize) then + write(*,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1 + write(15,'(/,a20,i4,a1,i4)')' Multibar rest, bars', + * ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1 + jprntb = 0 + end if + ibcoff = ibcoff+mbrest-1 + if (ibar.eq.1 .and. firstgulp .and. + * .not.btest(islur(1,1),5)) xb4mbr = facmtr*musicsize +c +c The above may be he only case where the space-before option is used in \mbrest +c + end if +c +c Move the read to after end-of-bar hardspace checks, so we get right poenom +c at end of a line. +c if (bar1syst) read(12,*) poenom +c +c Check for clef at start of bar. No slide yet. Also flags at end of prev. +c bar. This block is run at the start of every bar. May fail for flag at +c end of last bar. To account for necc. hardspaces, compute and store +c nhssys = # of hard spaces for this system +c hesk(nhssys) = elemskips avialable +c hpts(nhssys) = hard points needed, including notehead +c Here, merely insert placeholder into output. Later, when poe is computed, +c compute additional pts and store them in hpttot(1...nhstot). Finally in +c subroutine askfig, write true pts where placeholders are. +c + ioff = 0 + if (ibar .gt. 1) ioff = nib(1,ibar-1) + clchb = btest(islur(1,ioff+1),15) + putmbr = .false. + if (ismbr) then + if (clchb) then +c +c Clef change and multi-bar rest coming up. Kluge to get space at end of rest. +c + write(11,'(a)')sq//'let'//sq//'mbrt'//sq//'mbrest' + * //sq//'def'//sq//'mbrest#1#2#3{%' + write(11,'(a14,f4.1,a)')sq//'mbrt{#1}{#2}{',musicsize*.55, + * '}'//sq//'global'//sq//'let'//sq//'mbrest'//sq//'mbrt}%' + end if + ismbr = .false. + putmbr = .true. + end if + if (ibar .eq. ibarmbr) ismbr = .true. +c +c Set flag here so at start of next bar, if there's a clef change, can add space +c after the mbr with the above kluge +c + if (.not.(clchb .or. flgndb)) go to 23 +c +c Must check available space +c + ptsndb = 0. +c +c Zero out block signal +c + if (clchb) islur(1,ioff+1) = ibclr(islur(1,ioff+1),15) +c +c In this loop, we determine how much hardspace is needed (if any) +c 9/7/97 Note that for last bar in input block, if number of lines of +c music decreases in new block, highest numbered ones won't be checked +c since the loop below covers the new nvmx(iv), not necessarily the old +c one. +c 4/18/98 Apparently nmxsav was a solution to the above problem +c + do 16 iv = 1 , nv + do 16 kv = 1 , nvmxsav(iv) + ivx = ivmxsav(iv,kv) + ptsndv = flgndv(ivx)*wheadpt + ioff = 0 + if (ibar .gt. 1) then + ioff = nib(ivx,ibar-1) + ip = ioff + if (ibar.gt.2) ip = ioff-nib(ivx,ibar-2) +c prevtn(ivx) = tnote(iand(ipl(ivx,ip),255)) + prevtn(ivx) = tnote(ipl2(ivx,ip)) +c +c If ibar=1 (1st bar in input block), prevtn(ivx) was set at end of makeabar. +c + end if +c +c Only allow clef changes when ivx <= nv +c + if (ivx .le. nv) then + clchv(iv) = clchb .and. btest(islur(iv,ioff+1),11) + if (clchv(iv)) then +c +c Clef change in this voice. Turn off signal. Get space avail. +c + islur(iv,ioff+1) = ibclr(islur(iv,ioff+1),11) + if (abs(prevtn(iv)-space(nb)).lt.tol) ptsndv = + * ptsndv+clefend*wheadpt + end if + end if + ptsndb = max(ptsndb,ptsndv+wheadpt*xspfac) +16 continue +c +c ???? where is nb set??? nb probably in left over from makeabar +c + esk = feon(space(nb)*squez(nb)) + ptsdflt = esk*poenom-wheadpt +c if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0) then + if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0 + * .and. .not.putmbr) then +c +c Must ADD hardspace! So put in a placeholder, and store params for later. +c + if (islast) write(11,'(a)')sq//'xardspace{ pt}%' + nhssys = nhssys+1 + if (ptsndb-ptsdflt .gt. ptsgnd-poenom*eskgnd) then + hesk(nhssys) = esk + hpts(nhssys) = ptsndb+wheadpt + else + hesk(nhssys) = eskgnd + hpts(nhssys) = ptsgnd+wheadpt + end if + fixednew = fixednew+hpts(nhssys) + scaldold = scaldold+hesk(nhssys) + end if + if (clchb) then + do 17 iv = 1 , nv + if (clchv(iv)) then + notexq = sq//'znotes' + lnote = 7 + do 24 iiv = 2 , iv + notexq = notexq(1:lnote)//sepsymq(iiv-1) + lnote = lnote+1 +24 continue +c +c Recompute ioff since it will vary from voice to voice +c + if (ibar .eq. 1) then + ioff = 0 + else + ioff = nib(iv,ibar-1) + end if +c +c Must call clefsym to get nclef, even if there is a movement break +c + call clefsym(islur(iv,ioff+1),fmtq,lclef,nclef) + if (movbrk.eq.0 .and. + * islast) + * write(11,'(a)')notexq(1:lnote)//fmtq(1:lclef)//sq//'en%' + call wsclef(iv,ninow,clefq,nclef) + end if +17 continue + if (islast) write(11,'(a)')sq//'pmxnewclefs' + end if +23 continue +c +c End of loop for end-of-bar hardspaces and non-movbrk clef symbol. +c + if (bar1syst) then + read(12,*) poenom + end if +c +c Repeat symbols. Haven't slid down yet, so use islur(1,nib(1,ibar-1)+1) +c + if (ibar .eq. 1) then + islnow = islur(1,1) + iornqnow = iornq(1,1) + else + islnow = islur(1,nib(1,ibar-1)+1) + iornqnow = iornq(1,nib(1,ibar-1)+1) + end if +c +c Check for R-symbols set at end of prior input block +c + if (movbrk.eq.0 .and. rptfq2.ne.'E') then + if (rptfq2 .eq. 'D') then + islnow = ibset(islnow,26) + else if (rptfq2 .eq. 'r') then + islnow = ibset(islnow,6) + else if (rptfq2 .eq. 'd') then + islnow = ibset(islnow,8) + else if (rptfq2 .eq. 'b') then + islnow = ibset(islnow,25) + else + print* + print*,'Illegal symbol with "R" at end of input block:', + * rptfq2 + call stop1() + end if + rptfq2 = 'E' + end if + if (iand(islnow,352) .ne. 0) then +c +c Bit 5(lrpt), 6(rrpt), or 8(doublebar) has been set +c + lrpt = btest(islnow,5) + rrpt = btest(islnow,6) + lrptpend = lrpt.and.bar1syst + if (lrpt .and. .not.lrptpend) then + if (rrpt) then + if (islast) write(11,'(a)')sq//'setleftrightrepeat' + fixednew = fixednew+wheadpt*lrrptfac-0.4 + else + if (islast) write(11,'(a)')sq//'setleftrepeat' + fixednew = fixednew+wheadpt*rptfac-0.4 + end if + else if (rrpt) then + if (islast) write(11,'(a)')sq//'setrightrepeat' + fixednew = fixednew+wheadpt*rptfac-0.4 + else if (btest(islnow,8)) then + if (islast) write(11,'(a)')sq//'setdoublebar' + fixednew = fixednew+wheadpt*dbarfac-0.4 + end if + else if (btest(islnow,26)) then +c +c doubleBAR +c + if (islast) write(11,'(a)')sq//'setdoubleBAR' + fixednew = fixednew+wheadpt*ddbarfac-0.4 + else if (btest(iornqnow,29)) then +c +c no bar line +c +c-- if (islast) write(11,'(a)')sq//'setzalaligne' +c++ + if (islast) then + if (movbrk .eq. 0) then + write(11,'(a)')sq//'setzalaligne' + else +c +c Encountered "Rz" at start of input block at start of new movement, Must +c use newmovement macro with arg 4 rather than setzalaligne, since former +c already redefines stoppiece. +c + rptfq2 = 'z' + end if + end if +c++ + fixednew = fixednew-0.4 + end if +c +c 1st and 2nd endings +c + svolta = btest(islnow,7) + evolta = btest(islnow,9) + if (evolta) then + if (btest(islnow,10)) then + if (islast) write(11,'(a)')sq//'endvoltabox' + else + if (islast) write(11,'(a)')sq//'endvolta' + end if + onvolt = .false. + end if + if (svolta) then + nvolt = nvolt+1 + lvoltxt = index(voltxtq(nvolt),' ')-1 + if (lvoltxt .eq. 1) then + if (islast) write(11,'(a)')sq//'Setvolta' + * //voltxtq(nvolt)(1:1)//'%' + else + if (islast) write(11,'(a)')sq//'Setvolta'//'{'// + * voltxtq(nvolt)(1:lvoltxt)//'}%' + end if + onvolt = .true. + end if + if (ibar .gt. 1) then + ipnow = nib(1,ibar-1)+1 + else + ipnow = 1 + end if + iplnow = ipl(1,ipnow) + if (bar1syst) then +c +c If listslur>0, then there is at least one slur or tie carried over the break +c + ispstie = .false. + if (OptLineBreakTies .and. .not.fontslur .and. listslur.ne.0 + * .and. islast) + * call LineBreakTies(isdat1,isdat2,isdat3,isdat4, nsdat, + * ispstie,sepsymq) + iline = iline+1 +c +c End an old system, Start a new system +c + if (iline .ne. 1) then +c +c Not first line. +c Get corrected poe = points/elemskip for *previous* system +c + wdpt = widthpt*(1-fracindent) + poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/ + * (elsktot+fbar*nbarss-scaldold) + isyscnt = isyscnt+1 + poevec(isyscnt) = poe +c +c Transfer data for system into global arrays to hold until very end +c + do 9 ia = 1 , nasksys + iask = iask+1 + ask(iask) = wasksys(ia)/poe-abs(elasksys(ia)) +c +c Only admit negative ask if it was user-defined space, signalled by elask<=0. +c + if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.) +9 continue + do 25 ia = 1 , nhssys + nhstot = nhstot+1 + hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.) +25 continue +c +c Reset counters for new system +c + scaldold = 0. + fixednew = 0. + nasksys = 0 + nhssys = 0 + end if +c +c End of if block for first bar of non-first system. Still 1st bar, any system +c + if (islast.and.figbass) write(11,'(a)')sq//'fixdrop%' + isystpg = isystpg+1 +c +c Try moving the next stmt way down, to fix a bug and get \eject printed at +c end of single-system page. +c if (isystpg .eq. nsystp(ipage)) isystpg = 0 + read(12,*)nbarss,elsktot,fsyst,frac,eonk,ewmxk + if (iline .gt. 1) fracindent=frac + if (figbass) then + ifigdr(1,iline) = 4 + ifigdr(2,iline) = 4 + end if + slfac = slfac1*musicsize*elsktot + if (iline .ne. 1) then +c +c For the line just _finished_, put figdrop in separate file. +c + if (figbass) write(14,'(a9,i2,a10,i2,1x,a4)') + * sq//'figdrop=',ifigdr(1,iline-1), + * ' '//sq//'figdtwo=',ifigdr(2,iline-1),sq//'or%' +c +c Check slurs in top staff for interference w/ barno. Only check when +c # if digits in barno >= |isig| But to keep on/off phasing, must ALWAYS +c keep track of ons and offs when |isig|<=3. +c + ndigbn = int(alog10(ibarcnt+ibcoff+.01))+1 + isnx = 0 + if (ndigbn.ge.iabs(isig) .and. is1n1.gt.0) then +c +c There's a slur in top voice over the line break, hgt=is1n1, idcode=is2n1 +c Look for termination in remainder of this input block. If not found, +c just use is1n1. Remember, haven't slid down yet. +c + ioff = 0 + if (ibar .gt. 1) ioff = nib(ivmx(nv,nvmx(nv)),ibar-1) + do 50 isdat = 1 , nsdat + if (igetbits(isdat1(isdat),5,13).eq.ivmx(nv,nvmx(nv)) + * .and. .not.btest(isdat1(isdat),11) + * .and. igetbits(isdat1(isdat),7,19).eq.is2n1) then +c +c Found slur ending. Just check note height, can't do fine adjustments. +c +c is1n1 = max(is1n1,igetbits(isdat2(nsdat),7,19)) + is1n1 = max(is1n1,igetbits(isdat2(isdat),7,19)) + go to 51 + end if +50 continue +c +c If exiting loop normally, did not find end of slur. c'est la vie. +c +51 continue + isnx = idim(is1n1,ncmid(nv,1)+1+irzbnd) + if (isnx .gt. 0) then +c +c AHA! Slur likely to interfere with barno. +c +c Modified 090525 to use \bnrs +c + slint = .true. + fmtq = '(a16,i1,a14)' + if (irzbnd+isnx .gt. 9) fmtq = '(a16,i2,a14)' + if (islast) write(11,fmtq)sq//'def'//sq//'raisebarno{', + * irzbnd+isnx,'.5'//sq//'internote}%' +c if (islast) then +c if (isnx .le. 9) then +c write(11,'(a5,i1,a2)')sq//'bnrs',isnx,'0%' +c else +c write(11,'(a6,i2,a3)')sq//'bnrs{',isnx,'}0%' +c end if +c end if +c + end if + end if + if (movbrk .gt. 0) then +c +c movbrk = 0 +c Move the reset down, so can use movbrk>0 to stop extra meter prints. +c +c New movement. Redefine stoppiece, contpiece. These will be called either +c explicitly or as part of alaligne. +c indsym = 0,1,2 for doubleBAR , doublebar, rightrepeat. +c This is passed to \newmovement. +c + if (rptfq2 .eq. 'E') rptfq2 = 'D' + indsym = index('Ddrbz',rptfq2)-1 + rptfq2 = 'E' +c +c Also check for Rd or Rr set the normal way +c + if (btest(islnow,8)) then + indsym = 1 + else if (btest(islnow,6)) then + indsym = 2 + end if + if (indsym .lt. 0) then + print* + print*,'Illegal end symbol before "/"' + call stop1() + end if +c +c Check for continuation (no bar number reset) +c + if (islast.and. + * nobar1) write(11,'(a)')sq//'advance'//sq//'barno1' + * //sq//'startbarno'//sq//'barno%' +c +c Per Rainer's suggestion, changing \nbinstruments via 3rd arg of \newmovement +c +c if (movgap .lt. 10) then +c if (islast) write(11,'(a12,2i1,a1)') +c * sq//'newmovement',movgap,indsym,'%' +c else +c if (islast) write(11,'(a13,i2,a1,i1,a1)') +c * sq//'newmovement{',movgap,'}',indsym,'%' +c end if + if (islast) then + nmq = sq//'newmovement' + lnmq = 12 + if (movgap .lt. 10) then + lnmq = 14 + write(nmq(13:14),'(2i1)')movgap,indsym + else + lnmq = 17 + write(nmq(13:17),'(a1,i2,a1,i1)')'{',movgap,'}',indsym + end if + if (ninow .lt. 10) then + lnmq = lnmq+1 + write(nmq(lnmq:lnmq),'(i1)')ninow + else + lnmq = lnmq+4 + write(nmq(lnmq-3:lnmq),'(a1,i2,a1)')'{',ninow,'}' + end if + lnmq = lnmq+1 + write(nmq(lnmq:lnmq),'(a1)')'%' + write(11,'(a)')nmq(1:lnmq) + end if +c +c Change generalmeter if necessary +c + if (islast) call wgmeter(mtrnmp,mtrdnp) +c +c (Moved all name-writing to getnote, right when 'M' is detected) +c + if (btest(iplnow,28)) then +c +c Key signature at movement break +c + iplnow = ibclr(iplnow,28) + if (isig .gt. 0) then + if (islast) write(11,'(a18,i1,a2)') + * sq//'generalsignature{',isig,'}%' + else + if (islast) write(11,'(a18,i2,a2)') + * sq//'generalsignature{',isig,'}%' + end if + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + end if + if (parmov .ge. -.1) then +c +c Resent paragraph indentation +c + ipi = parmov*widthpt+.1 + if (ipi .lt. 10) then + if (islast) write(11,'(a11,i1,a2)') + * sq//'parindent ',ipi,'pt' + else if (ipi .lt. 100) then + if (islast) + * write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt' + else + if (islast) + * write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt' + end if + end if + end if + if (isystpg .eq. 1) then +c +c First line on a page (not 1st page, still first bar). Tidy up old page +c then eject. +c +c Removed this 5/13/01 as it was causing double endvoltas. This probably +c is only needed at the end in case there is no endvolta specified. +c if (onvolt) then +cc if (islast) write(11,'(a)')sq//'endvoltabox%' +cc onvolt = .false. +c end if +c +c +c Check for meter change at start of a new PAGE +c + if (mtrnuml .gt. 0) then +c +c Meter change at start of a new page. Ugly repeated coding here. +c + mtrnms = mtrnuml + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + mtrnuml = mtrnms + if (movbrk .eq. 0 .and. islast) + * call wgmeter(mtrnmp,mtrdnp) + end if +c +c Key signature change? +c + if (btest(iplnow,28) .and. movbrk.eq.0) then + notexq = sq//'xbar'//sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'generalsignature{' + lnote = 49 + if (isig .lt. 0) then + notexq = notexq(1:49)//'-' + lnote = 50 + end if + if (islast) write(11,'(a)') + * notexq(1:lnote)//chax(48+abs(isig))//'}%' + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + if (islast) write(11,'(a)')sq//'zchangecontext'//sq + * //'addspace{-'//sq//'afterruleskip}' + * //sq//'zstoppiece'//sq//'PMXbarnotrue%' + else if (mtrnuml.gt.0 .and. movbrk.eq.0) then +c +c Meter change but no signature change +c + if (islast) + * write(11,'(a)')sq//'xchangecontext'//sq//'addspace{-'// + * sq//'afterruleskip}'//sq//'let'//sq//'bnat'//sq// + * 'barnoadd%' + if (islast) + * write(11,'(a)')sq//'def'//sq//'barnoadd{'//sq//'let'// + * sq//'barnoadd'//sq//'bnat}'//sq//'zstoppiece%' + else + if (islast) write(11,'(a)')sq//'stoppiece%' + end if +c +c This is the key spot when vshrink is used. Value of vshrink here comes from +c just after the prior pagebreak, i.e., it is not affected by "Av" +c that may have been entered at this pagebreak, since that only affects usevshrink. +c So choose page *ending* (with or without \vfill) depending on old vshrink. Then +c check value of usevshrink to reset vshrink if necessary for the new page, where +c we have to set \interstaff and later call puttitle. +c Top of first page needs special treatment. For this we use +c novshrinktop, which was set in g1etnote on the first pass, since on +c second pass, vshrink at top of page one is dealt with in topfile, which is called +c *before* any reading in any "Av" at the top of the first input block. +c + if (.not.vshrink) then + xnstbot = xnsttop(ipage)*etabot/etatop + if (xnstbot .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else + fmtq = '(a,f4.1,a)' + end if + if (islast) write(11,fmtq)sq//'vskip',xnstbot, + * sq//'Interligne'//sq//'eject%' + else + if (islast) write(11,'(a)') sq//'vfill'//sq//'eject%' + end if + ipage = ipage+1 +c +c Now that page is ejected, compute new vshrink +c + vshrink = xintstaff(ipage).gt.20 .and. usevshrink + if (vshrink) then + xinsnow = 10 + else + xinsnow = xintstaff(ipage) + end if + if (fintstf.gt.0 .and. ipage.gt.1) then + xinsnow = xinsnow*fintstf/gintstf + fintstf = -1. + end if + if (xinsnow .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else if (xinsnow .lt. 99.95) then + fmtq = '(a,f4.1,a)' + else + fmtq = '(a,f5.1,a)' + end if +c +c Vertical spacing parameters, then restart +c + if (islast) write(11,fmtq)sq//'interstaff{',xinsnow, + * '}'//sq//'contpiece' +c +c Check for meter change at start of a new PAGE +c + if (mtrnuml .gt. 0) then +c +c Meter change at start of a new page +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (movbrk .eq. 0) then + if (islast) call wgmeter(mtrnmp,mtrdnp) + if (mtrdnp .gt. 0) then + if (islast) write(11,'(a)')sq//'newtimes2%' + if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize + end if + end if + end if +c +c If no real titles here, which there probably will never be, make vertical +c space at page top with \titles{...}. headlog=.false.<=>no real titles +c + call puttitle(inhnoh,xnsttop(ipage),etatop, + * sq,etait,etatc,etacs1,nv,vshrink,sepsymq) + if (HeaderSpecial) +c +c Write special header for first page +c + * write(11,'(a)')chax(92)//'special{header=psslurs.pro}%' + else +c +c First bar of system, not a new page, force line break +c + if (btest(iplnow,28)) then +c +c Signature change +c + notexq = sq//'xbar'//sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'generalsignature{' + lnote = 49 + if (isig .lt. 0) then + notexq = notexq(1:49)//'-' + lnote = 50 + end if + if (islast) write(11,'(a)')notexq(1:lnote) + * //chax(48+abs(isig))//'}%' + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%' + if (mtrnuml .ne. 0) then +c +c Meter+sig change, new line, may need mods if movement break here. +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (islast) then + call wgmeter(mtrnmp,mtrdnp) + write(11,'(a)')sq//'xchangecontext'//sq// +c * 'addspace{-'//sq//'afterruleskip}'//sq//'def' + * 'addspace{-'//sq//'afterruleskip}' +c * //sq//'writezbarno{}'//sq//'zalaligne%' + * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%' + write(11,'(a)')sq//'addspace{-'//sq + * //'afterruleskip}%' + call wgmeter(mtrnmp,mtrdnp) + write(11,'(a)')sq//'zchangecontext' + end if + else + if (islast) write(11,'(a)')sq//'xchangecontext'//sq// +c * 'addspace{-'//sq//'afterruleskip}'//sq//'def'// + * 'addspace{-'//sq//'afterruleskip}' +c * sq//'writezbarno{}'//sq//'zalaligne%' + * //sq//'zstoppiece'//sq//'PMXbarnotrue'//sq//'contpiece%' + end if + else if (mtrnuml .eq. 0) then +c +c No meter change +c + if (islast) write(11,'(a)')sq//'alaligne' + else +c +c New meter, no new sig, end of line, not new page. +c +c \generalmeter{\meterfrac{3}{4}}% +c \xchangecontext\addspace{-\afterruleskip}% +c \zalaligne\generalmeter{\meterfrac{3}{4}}\addspace{-\afterruleskip}% +c \zchangecontext +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (movbrk .eq. 0) then + if (islast) call wgmeter(mtrnmp,mtrdnp) + if (mtrdnp .gt. 0) then + if (islast) then + write(11,'(a)') + * sq//'let'//sq//'bnat'//sq//'barnoadd' + * //sq//'def'//sq//'barnoadd{'//sq//'empty}%' + write(11,'(a)')sq//'xchangecontext'//sq// + * 'addspace{-'//sq//'afterruleskip}'//sq// + * 'zalaligne'//sq//'let'//sq//'barnoadd'//sq//'bnat' + call wgmeter(mtrnmp,mtrdnp) + write(11,'(a)')sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'zchangecontext' + end if + if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize + else + if (islast) write(11,'(a)')sq//'alaligne' + end if + else + if (islast) write(11,'(a)')sq//'alaligne' + end if + end if + end if +c +c Modified 090525 to use \bnrs +c + if (slint) then + slint = .false. + if (islast) write(11,'(a16,i1,a14)')sq//'def'//sq// + * 'raisebarno{',irzbnd,'.5'//sq//'internote}%' + end if + movbrk = 0 + end if +c +c Clean up if we squelched bar number reset at movement break +c + if (nobar1) then + if (islast) write(11,'(a)')sq//'startbarno1' + nobar1 = .false. + end if + read(12,*,end=14)iauto +14 continue +c +c We come thru here for the 1st bar of every system, so initialize is1n1 +c + is1n1 = 0 +c +c Brought down from above +c + if (isystpg .eq. nsystp(ipage)) isystpg = 0 +c +c Check for linebreak ties +c + if (ispstie) + * call LineBreakTies(isdat1,isdat2,isdat3,isdat4,nsdat, + * ispstie,sepsymq) + else +c +c Not first bar of system +c + if (btest(iplnow,28)) then +c +c Signature change +c + if (mtrnuml .ne. 0) then +c +c Meter+signature change mid line, assume no movement break +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (islast) call wgmeter(mtrnmp,mtrdnp) + notexq = sq//'generalsignature{' + lnote = 18 + if (isig .lt. 0) then + notexq = notexq(1:18)//'-' + lnote = 19 + end if + if (islast) then + iptemp = 48+abs(isig) + charq = chax(iptemp) + notexq = notexq(1:lnote)//charq//'}%' + lnote = lnote+3 + write(11,'(a)')notexq(1:lnote) + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + write(11,'(a)')sq//'xchangecontext%' + end if + if (ibar .eq. ibarmbr) then +c +c Compute space for multibar rest +c + if (lastisig*isig .ge. 0) then + naccs = max(abs(lastisig),abs(isig)) + else + naccs = abs(lastisig-isig) + end if + xb4mbr = (facmtr+naccs*.24)*musicsize + end if + else +c +c Signature change only +c + notexq = sq//'xbar'//sq//'addspace{-'//sq// + * 'afterruleskip}'//sq//'generalsignature{' + lnote = 49 + if (isig .lt. 0) then + notexq = notexq(1:49)//'-' + lnote = 50 + end if + if (islast) + * write(11,'(a)')notexq(1:lnote)//chax(48+abs(isig))//'}%' + if (islast .and. LaterInstTrans) then + call Writesetsign(nInstTrans,iInstTrans,iTransKey, + * LaterInstTrans) + end if + if (islast) write(11,'(a)')sq//'zchangecontext'//sq + * //'addspace{-.5'// sq//'afterruleskip}%' + if (ibar .eq. ibarmbr) then +c +c Compute space for multibar rest +c + if (lastisig*isig .ge. 0) then + naccs = max(abs(lastisig),abs(isig)) + else + naccs = abs(lastisig-isig) + end if + xb4mbr = naccs*.24*musicsize + end if + end if + else if (mtrnuml .eq. 0) then +c +c No meter change +c + if (islast) write(11,'(a)')sq//'xbar' + else +c +c Change meter midline +c + call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) + if (movbrk .eq. 0) then + if (islast) call wgmeter(mtrnmp,mtrdnp) + if (mtrdnp .gt. 0) then + if (islast) write(11,'(a,2i1,a)')sq//'newtimes0%' + if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize + else + if (islast) write(11,'(a)')sq//'xbar' + end if + end if + end if + end if +c +c Now that xbar's are written, can put in left-repeats at line beginnings +c + if (lrptpend) then + if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1' + * //sq//'leftrepeat' + lrptpend = .false. + end if + if (ibar .gt. 1) then +c +c For bars after first, slide all stuff down to beginning of arrays +c + do 11 iv = 1 , nv + do 11 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + ioff = nib(ivx,ibar-1) + do 12 ip = 1 , nib(ivx,ibar)-ioff + nolev(ivx,ip) = nolev(ivx,ip+ioff) + nodur(ivx,ip) = nodur(ivx,ip+ioff) + nacc(ivx,ip) = nacc(ivx,ip+ioff) + irest(ivx,ip) = irest(ivx,ip+ioff) + islur(ivx,ip) = islur(ivx,ip+ioff) + ipl(ivx,ip) = ipl(ivx,ip+ioff) + iornq(ivx,ip) = iornq(ivx,ip+ioff) + mult(ivx,ip) = mult(ivx,ip+ioff) +c if (ivx.le.2 .and. figbass) +c * isfig(ivx,ip) = isfig(ivx,ip+ioff) + if (figbass .and. ivx.eq.1 .or. ivx.eq.ivxfig2) then + if (ivx.eq.1) then + isfig(1,ip) = isfig(1,ip+ioff) + else + isfig(2,ip) = isfig(2,ip+ioff) + end if + end if +12 continue + if (ivx.le.nv .and. ncc(iv).gt.1) then + islide = 0 + do 13 icc = 1 , ncc(iv) + if (tcc(iv,icc) .le. lenbar) then +c +c This time will drop <=0 when slid. +c + islide = icc-1 + ncmidcc(iv,1) = ncmidcc(iv,icc) + else + tcc(iv,icc-islide) = tcc(iv,icc)-lenbar + ncmidcc(iv,icc-islide) = ncmidcc(iv,icc) + end if +13 continue + ncc(iv) = ncc(iv)-islide + tcc(iv,1) = 0. + end if +11 continue + do 15 ig = 1 , ngrace + ipg(ig) = ipg(ig)-nib(ivg(ig),ibar-1) + if (ibar .gt. 2) ipg(ig) = ipg(ig)+nib(ivg(ig),ibar-2) +15 continue + do 21 il = 1 , nlit + iplit(il) = iplit(il)-nib(ivlit(il),ibar-1) + if (ibar .gt. 2) iplit(il) = iplit(il)+nib(ivlit(il),ibar-2) +21 continue + do 22 it = 1 , ntrill + iptrill(it) = iptrill(it)-nib(ivtrill(it),ibar-1) + if (ibar .gt. 2) iptrill(it) = + * iptrill(it)+nib(ivtrill(it),ibar-2) +22 continue + do 27 icrd = 1 , ncrd +c ivx = iand(15,ishft(icrdat(icrd),-8)) + ivx = iand(15,ishft(icrdat(icrd),-8)) + * +16*igetbits(icrdat(icrd),1,28) + ipnew = iand(255,icrdat(icrd))-nib(ivx,ibar-1) + if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2) + icrdat(icrd) = iand(not(255),icrdat(icrd)) + icrdat(icrd) = ior(max(0,ipnew),icrdat(icrd)) +27 continue + do 29 iudorn = 1 , nudorn +c ivx = iand(15,ishft(kudorn(iudorn),-8)) + ivx = ivxudorn(iudorn) + ipnew = iand(255,kudorn(iudorn))-nib(ivx,ibar-1) + if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2) + kudorn(iudorn) = iand(not(255),kudorn(iudorn)) + kudorn(iudorn) = ior(max(0,ipnew),kudorn(iudorn)) +29 continue + do 42 idyn = 1 , ndyn + idynd = idyndat(idyn) +c ivx = iand(15,idynd) + ivx = iand(15,idynd)+16*igetbits(idynda2(idyn),1,10) + ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1) +c +c The following construction avoids array bound errors in some compilers +c + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) + call setbits(idynd,8,4,ipnew) + idyndat(idyn) = idynd +42 continue + do 43 itxtdyn = 1 , ntxtdyn + idynd = ivxiptxt(itxtdyn) +c ivx = iand(15,idynd) + ivx = iand(31,idynd) +c ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1) + ipnew = igetbits(idynd,8,5)-nib(ivx,ibar-1) + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) +c call setbits(idynd,8,4,ipnew) + call setbits(idynd,8,5,ipnew) + ivxiptxt(itxtdyn) = idynd +43 continue + do 41 isdat = 1 , nsdat + isdata = isdat1(isdat) + ivx = ivmx(igetbits(isdata,5,13),igetbits(isdata,1,12)+1) + ipnew = igetbits(isdata,8,3)-nib(ivx,ibar-1) + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) + call setbits(isdata,8,3,ipnew) + isdat1(isdat) = isdata +41 continue + do 44 ibc = 1 , nbc +c ivx = iand(15,ibcdata(ibc)) + ivx = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) + ipnew = igetbits(ibcdata(ibc),8,4)-nib(ivx,ibar-1) + if (ibar .gt. 2) then + ipnew = ipnew+nib(ivx,ibar-2) + end if + ipnew = dim(ipnew,0) + call setbits(ibcdata(ibc),8,4,ipnew) +44 continue + do 45 iarps = 1 , NumArpShift + IpArpShift(iarps) = + * IpArpShift(iarps)-nib(IvArpShift(iarps),ibar-1) + if (ibar .gt. 2) then + IpArpShift(iarps) = + * IpArpShift(iarps)+nib(IvArpShift(iarps),ibar-2) + end if +45 continue +c +c Bookkeeping for figures. This will set nfigs = 0 if there are no figs left. +c If there are figs left, it will reset all times relative to start of +c current bar. +c + do 46 ivx = 1 , 2 + if (figbass) then + islide = 0 + do 20 jfig = 1 , nfigs(ivx) + if (itfig(ivx,jfig) .lt. lenbar) then +c +c This figure was already used +c + islide = jfig + else + itfig(ivx,jfig-islide) = itfig(ivx,jfig)-lenbar + figq(ivx,jfig-islide) = figq(ivx,jfig) + itoff(ivx,jfig-islide) = itoff(ivx,jfig) + ivupfig(ivx,jfig-islide) = ivupfig(ivx,jfig) + end if +20 continue + nfigs(ivx) = nfigs(ivx)-islide + end if + if (nfigs(2) .eq. 0) go to 47 +46 continue +47 continue + end if +c +c End of sliding down for bars after first in gulp. +c +c The following may not be needed by makeabar, but just in case... +c + if (firstgulp .and. lenb0.ne.0) then + if (ibar .eq. 1) then + lenbar = lenb0 + else + lenbar = lenb1 + end if + end if +c +c Equal line spacing stuff +c + if (equalize .and. bar1syst) then + if (isystpg .eq. 1) then + write(11,'(a)')sq//'starteq%' + else if (isystpg .eq. nsystp(ipage)-1) then + write(11,'(a)')sq//'endeq%' + end if + end if + call make1bar(ibmrep,tglp1,tstart,cwrest,squez, + * istop,numbms,istart) + call make2bar(ninow,tglp1,tstart,cwrest,squez, + * istop,numbms,istart,clefq) +c +c Hardspace before barline? +c + hardb4 = 0. + do 35 iv = 1 , nv + do 35 kv = 1 , nvmx(iv) + ivx = ivmx(iv,kv) + if (btest(irest(ivx,nn(ivx)),18)) then + nudoff(ivx) = nudoff(ivx)+1 + hardb4 = max(hardb4,udoff(ivx,nudoff(ivx))) + end if +35 continue + if (hardb4 .gt. 0.) then + if (islast) write(11,'(a11,f5.1,a4)')sq + * //'hardspace{',hardb4,'pt}%' + fixednew = fixednew-hardb4 + end if +10 continue + firstgulp = .false. + lenb0 = 0 + go to 30 +40 close(12) + close(13) + ilbuf = 1 + ipbuf = 0 + wdpt = widthpt + if (iline .eq. 1) wdpt = widthpt*(1-fracindent) + poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/ + * (elsktot+fbar*nbarss-scaldold) + poevec(nsyst) = poe + if (.not.islast) then + close(11) + close(16) + if (figbass) close(14) + return + end if + do 19 ia = 1 , nasksys + iask = iask+1 + ask(iask) = wasksys(ia)/poe-abs(elasksys(ia)) + if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.) +19 continue + do 26 ia = 1 , nhssys + nhstot = nhstot+1 + hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.) +26 continue + if (islast .and. + * onvolt) write(11,'(a)')sq//'endvoltabox' + if (rptfq2 .ne. 'E') then +c +c Terminal repeat. Right or double? +c + if (rptfq2 .eq. 'r') then + if (islast) write(11,'(a)')sq//'setrightrepeat' + * //sq//'endpiece' + else if (rptfq2 .eq. 'd') then + if (islast) write(11,'(a)')sq//'setdoublebar'//sq//'endpiece' + else if (rptfq2 .eq. 'b') then + if (islast) write(11,'(a)')sq//'endpiece' + else if (rptfq2 .eq. 'z') then + if (islast) write(11,'(a)')sq//'setzalaligne'//sq//'Endpiece' + else +c else if (rptfq2 .ne. 'D') then + print* + print*,'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2 + write(15,*)'R? , ? not "d","r",or"b","z"; rptfq2:',rptfq2 + if (islast) write(11,'(a)')sq//'Endpiece' + end if + else + if (islast) write(11,'(a)')sq//'Endpiece' + end if + if (.not.vshrink) then + xnstbot = xnsttop(ipage)*etabot/etatop + if (xnstbot .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else + fmtq = '(a,f4.1,a)' + end if + if (islast) write(11,fmtq)sq//'vskip',xnstbot, + * sq//'Interligne'//sq//'eject'//sq//'endmuflex' + if (islast) write(11,'(a)')sq//'bye' + else + if (islast) write(11,'(a)') + * sq//'vfill'//sq//'eject'//sq//'endmuflex' + if (islast) write(11,'(a)')sq//'bye' + end if + rewind(11) + if (figbass) then + write(14,'(a9,i2,a10,i2,1x,a5)') + * sq//'figdrop=',ifigdr(1,iline), + * ' '//sq//'figdtwo=',ifigdr(2,iline),sq//'fi}%' + rewind(14) + end if + call askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0) + if (.not.optimize) then + print* + print*,'Writing ' + * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex' + print*,'Done with second PMX pass.' + write(15,'(/,a)')'Writing ' + * //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex' + write(15,'(a)')' Done with second PMX pass. Now run TeX' + end if + return + end + subroutine poestats(nsyst,poe,poebar,devnorm) + parameter (nks=125) +c +c Compute avg. & norm. std. dev. of poe. +c + real*4 poe(nks) + sumx = 0. + sumxx = 0. + do 1 isyst = 1 , nsyst + sumx = sumx+poe(isyst) + sumxx = sumxx+poe(isyst)**2 +1 continue +2 continue + devnorm = sqrt(nsyst*sumxx/sumx**2-1) + poebar = sumx/nsyst + return + end + subroutine precrd(ivx,ip,nolevm,nacc,ipl,irest,udq, + * twooftwo,icashft) +c +c Analyzes chords, data to be used with slurs on chords and plain chords. +c Check for 2nds, shift notes if neccesary. +c ipl(10) chord present +c irest(20) set if any note is right shifted +c irest(27) set if any note is left shifted +c ipl(8|9) left|right shift main note +c icrdat(23|24) ditto chord note +c udq is updown-ness, needed to analyze 2nds. +c levtabl(i)=0 if no note at this level, -1 if main note, icrd if chord note. +c icrdot(icrd)(27-29) sequence order of chord note if accid, top down +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + logical btest,is2nd,twooftwo + integer*4 kicrd(10),levtabl(88) + character*1 udq + do 11 i = 1 , 88 + levtabl(i) = 0 +11 continue + do 1 icrd1 = 1 , ncrd + ivx1 = iand(15,ishft(icrdat(icrd1),-8)) + * +16*igetbits(icrdat(icrd1),1,28) + ip1 = iand(255,icrdat(icrd1)) + if (ip1.eq.ip .and. ivx1.eq.ivx) go to 2 +1 continue + print* + print*, + * 'Cannot find first chord note in precrd. Send source to Dr. Don!' + call stop1() +2 continue + maxlev = nolevm + minlev = nolevm + levtabl(nolevm) = -1 + is2nd = .false. + naccid = 0 + levmaxacc = -100 + levminacc = 1000 +c +c Check 1st 3 bits of nacc for accid on main note of chord. +c + if (iand(7,nacc) .gt. 0) then + naccid = 1 +c +c Start list of notes with accid's. There will be naccid of them. kicrd=0 if main, +c otherwise icrd value for note with accidental. +c + kicrd(1) = 0 + levmaxacc = nolevm + levminacc = nolevm +c +c Start the level-ranking +c + icrdot0 = 1 + end if + do 3 icrd2 = icrd1 , ncrd + nolev = igetbits(icrdat(icrd2),7,12) + levtabl(nolev) = icrd2 + maxlev = max(maxlev,nolev) + minlev = min(minlev,nolev) +c +c Check for accidental +c + if (btest(icrdat(icrd2),19)) then + naccid = naccid+1 + levmaxacc = max(levmaxacc,nolev) + levminacc = min(levminacc,nolev) +c +c Add this icrd to list of values for notes with accid's. +c + kicrd(naccid) = icrd2 + if (.not.btest(nacc,28)) then +c +c Order not forced, so get the level-ranking, top down +c + iorder = 1 + do 12 iaccid = 1 , naccid-1 + if (kicrd(iaccid) .eq. 0) then + if (nolevm .gt. nolev) then + iorder = iorder+1 + else + icrdot0 = icrdot0+1 + end if + else + if (igetbits(icrdat(kicrd(iaccid)),7,12) + * .gt. nolev) then + iorder = iorder+1 + else + iold = igetbits(icrdot(kicrd(iaccid)),3,27) + call setbits(icrdot(kicrd(iaccid)),3,27,iold+1) + end if + end if +12 continue + call setbits(icrdot(icrd2),3,27,iorder) + end if + end if +c +c Exit loop if last note in this chord +c + if (icrd2 .eq. ncrd) go to 4 + if (igetbits(icrdat(icrd2+1),8,0) .ne. ip .or. +c * igetbits(icrdat(icrd2+1),4,8) .ne. ivx) go to 4 + * igetbits(icrdat(icrd2+1),4,8) + * +16*igetbits(icrdat(icrd2+1),1,28) .ne. ivx) go to 4 +3 continue + print* + print*,'Failed to find last chord note. Send source to Dr. Don!' + call stop1() +4 continue +c +c Now icrd1, icrd2 define range of icrd for this chord. +c +c Bypass autos-shifting if any manual shifts are present +c + if (btest(irest,20) .or. btest(irest,27)) go to 10 +c +c Check for 2nds +c + do 5 ilev = 1 , 87 + if (levtabl(ilev).ne.0 .and. levtabl(ilev+1).ne.0) then +c +c There is at least one 2nd.. +c + if (udq .eq. 'u') then +c +c Upstem. Start with 2nd just found and go up, rt-shifting upper +c member of each pair +c + ile = ilev +c +c Set main-note flag for ANY right-shift +c + irest = ibset(irest,20) +7 continue + if (levtabl(ile+1) .lt. 0) then +c +c Upstem, & upper member is main so must be rt-shifted. This would move +c stem too, so we rt-shift the OTHER note, and set flag that signals +c to interchange pitches just when these two notes are placed. +c + nacc = ibset(nacc,30) + icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),24) + else +c +c Upper member is chord note, must be rt-shifted +c + icrdat(levtabl(ile+1)) = ibset(icrdat(levtabl(ile+1)),24) + end if + ile = ile+1 +8 continue + ile = ile+1 + if (ile .lt. 87) then + if (levtabl(ile).ne.0 .and. levtabl(ile+1).ne.0) then + go to 7 + else + go to 8 + end if + end if + go to 10 + else +c +c Downstem. Start at top and work down, left-shifting lower member of each pair. +c We know that lowest pair is at (ilev,ilev+1). +c + ile = 88 +c +c Set main-note flag for ANY right-shift +c + irest = ibset(irest,27) +9 continue + if (levtabl(ile).ne.0 .and. levtabl(ile-1).ne.0) then + if (levtabl(ile-1) .lt. 0) then +c ipl = ibset(ipl,8) +c +c Dnstem, & lower member is main so must be left-shifted. This would move +c stem too, so we left-shift the OTHER note, and set flag that signals +c to interchange pitches just when these two notes are placed. +c + nacc = ibset(nacc,31) + icrdat(levtabl(ile)) = ibset(icrdat(levtabl(ile)),23) + else +c +c Lower member is chord note, must be shifted +c + icrdat(levtabl(ile-1)) = + * ibset(icrdat(levtabl(ile-1)),23) + end if + ile = ile-1 + end if + ile = ile-1 + if (ile .ge. ilev+1) go to 9 + go to 10 + end if + end if +5 continue +10 continue +c +c Done with 2nds, now do accid's. Call even if just one, in case left shifts. +c +c if (naccid .gt. 1) call crdaccs(nacc,ipl,irest,naccid, + if (naccid .ge. 1) call crdaccs(nacc,ipl,irest,naccid, + * kicrd,nolevm,levmaxacc,levminacc,icrdot0,twooftwo,icashft) + return + end + subroutine printl(string) + character*(*) string +c +c Send string to console and to log file +c + print*,string + write(15,'(a)')string + return + end + subroutine putarp(tnow,iv,ip,nolev,ncm,soutq,lsout) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comtol/ tol + common /comArpShift/NumArpShift,IvArpShift(20),IpArpShift(20), + * ArpShift(20) + logical lowdot,IsArpShift + character*80 soutq + character*79 notexq + character*8 symq(2) + character*1 chax + data symq /'raisearp','arpeggio'/ + +c +c Find which iarp, if any +c + do 1 iarp = 1 , narp + if (abs(tnow-tar(iarp)).lt.tol) go to 2 +1 continue +c +c If here, this is the *first* call for this arp. +c + narp = narp+1 + tar(narp) = tnow+tol*.5 + ivar1(narp) = iv + ipar1(narp) = ip + levar1(narp) = nolev + ncmar1(narp) = ncm + return +2 continue +c +c If here, this is *second* call at this time, iarp points to values from 1st. +c +c Check for shift. Set IsArpShift and iarps +c + do 3 iarps = 1 , NumArpShift + if (IvArpShift(iarps) .eq. ivar1(iarp) .and. + * IpArpShift(iarps) .eq. ipar1(iarp)) then + IsArpShift = .true. + notexq = chax(92)//'loffset{' + write(notexq(10:14),'(f3.1,a2)') Arpshift(iarps),'}{' + lnote = 14 + go to 4 + end if +3 continue + IsArpShift = .false. + lnote = 0 +4 continue + if (iv .eq. ivar1(iarp)) then +c +c Arp is in a single staff. +c + levbot = min(levar1(iarp),nolev)-ncm+3 + invert = abs(levar1(iarp)-nolev)+1 + else +c +c Arp covers >1 staff. Lower staff has to be the first, upper is current and +c is where the symbol will be written. +c + levbot = -nint(2*xinsnow)+3+levar1(iarp)-ncmar1(iarp) + invert = -levbot+4+nolev-ncm +c print*,'xinsnow,levar1,ncmar1,levbot,nolev,ncm:' +c write(*,'(f5.1,5i5)')xinsnow,levar1(iarp),ncmar1(iarp), +c *levbot,nolev,ncm + end if +c +c isym will be (1,2) if invert is (even,odd). If even, raise .5\internote +c + isym = mod(invert,2)+1 + ilvert = (invert+1)/2 + if (levbot .ge. 0 .and. levbot .le. 9) then +c +c Single digit +c + if (.not.IsArpShift) then + notexq = chax(92)//symq(isym)//chax(48+levbot) + else + notexq = notexq(1:lnote)// + * chax(92)//symq(isym)//chax(48+levbot) + end if + lnote = lnote+10 + else + if (.not.IsArpShift) then + notexq = chax(92)//symq(isym)//'{' + else + notexq = notexq(1:lnote)//chax(92)//symq(isym)//'{' + end if + lnote = lnote+10 + if (levbot .ge. -9) then +c +c Need two spaces for number +c + write(notexq(lnote+1:lnote+3),'(i2,a1)')levbot,'}' + lnote = lnote+3 + else + write(notexq(lnote+1:lnote+4),'(i3,a1)')levbot,'}' + lnote = lnote+4 + end if + end if +c if (ilvert .le. 9) then +c call addstr(notexq(1:lnote)//chax(48+ilvert),lnote+1, +c * soutq,lsout) +c else +c write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}' +c call addstr(notexq(1:lnote+4),lnote+4,soutq,lsout) +c end if + + if (ilvert .gt. 9) then + write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//chax(48+ilvert) + lnote = lnote+1 + end if + if (IsArpShift) then + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + call addstr(notexq(1:lnote),lnote,soutq,lsout) +c +c cancel out the stored time, to permit two arps at same time! +c + tar(iarp) = -1. + return + end + subroutine putast(elask,indxask,outq) + character*129 outq,tag + character*9 fmtq + if (elask .ge. 0.) then + if (elask.lt.0.995) then + lp = 3 + else if (elask .lt. 9.995) then + lp = 4 + else + lp = 5 + end if + write(fmtq,'(a5,i1,a3)')'(a2,f',lp,'.2)' + else + lp = 5 + fmtq = '(a2,f5.1)' + end if +c +c Overwrite as follows: ...xyz*ask *lmnop... -> +c ...xyz*ast{.nn}*lmnop... +c ...xyz*ast{n.nn}*lmnop... +c ...xyz*ast{nn.nn}*lmnop... +c or for negative, ...xyz*ast{-nn.n}*lmnop... + tag = outq(indxask+9:) + write(outq(indxask+3:),fmtq)'t{',elask + outq = outq(1:indxask+4+lp)//'}'//tag + return + end + subroutine putcb(ivx,ip,notexq,lnote) + common /comcb/ nbc,ibcdata(36) + character*79 notexq + logical btest +c ivxip = ivx+16*ip + do 1 ibc = 1 , nbc +c if (ivxip .eq. iand(1023,ibcdata(ibc))) go to 2 +c if (ivx.eq.iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) +c * .and. ip.eq.iand(1008,ibcdata(ibc))) go to 2 + ivxbc = iand(15,ibcdata(ibc))+16*igetbits(ibcdata(ibc),1,28) + ipbc = igetbits(ibcdata(ibc),8,4) + if (ivx .eq. ivxbc .and. ip .eq.ipbc) go to 2 +1 continue + call printl('Error in putbc, Call Dr. Don') + stop +2 continue + if (btest(ibcdata(ibc),27)) then + lnote = 8 + notexq = char(92)//'pbreath' + else + lnote = 9 + notexq = char(92)//'pcaesura' + end if + ivshft = igetbits(ibcdata(ibc),6,13) +c?? ivshft = igetbits(ibcdata(ibc),6,13)-32 + if (ivshft .gt. 0) ivshft = ivshft-32 + if (ivshft.lt.0 .or. ivshft.gt.9) then + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (ivshft .lt. -9) then + write(notexq(lnote+1:lnote+3),'(i3)')ivshft + lnote = lnote+3 + else + write(notexq(lnote+1:lnote+2),'(i2)')ivshft + lnote = lnote+2 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + else + notexq = notexq(1:lnote)//char(48+ivshft) + lnote = lnote+1 + end if + ihshft = igetbits(ibcdata(ibc),8,19) + if (ihshft .eq. 0) then + notexq = notexq(1:lnote)//'0' + lnote = lnote+1 + else + hshft = .1*(ihshft-128) +c +c -12.8<hshft<12.8 +c + notexq = notexq(1:lnote)//'{' + lnote = lnote+1 + if (hshft .lt. -9.95) then + write(notexq(lnote+1:lnote+5),'(f5.1)')hshft + lnote = lnote+5 + else if (hshft.lt.-0.05 .or. hshft.gt.9.95) then + write(notexq(lnote+1:lnote+4),'(f4.1)')hshft + lnote = lnote+4 + else + write(notexq(lnote+1:lnote+3),'(f3.1)')hshft + lnote = lnote+3 + end if + notexq = notexq(1:lnote)//'}' + lnote = lnote+1 + end if + return + end + subroutine putfig(ivx,ifig,offnsk,figcheck,soutq,lsout) + parameter (nm=24) + common /comfig/ itfig(2,74),figqq(2,74),ivupfig(2,74),nfigs(2), + * fullsize(nm),ivxfig2 + character*10 figqq,figq + character*80 soutq,notexq + character*1 ch1q,ch2q,sq,chax + character*5 nofq,nofaq + character*4 Figutq,Conttq + logical figcheck + if (ivx .eq. 1) then + Figutq = 'Figu' + Conttq = 'Cont' + else + Figutq = 'Figt' + Conttq = 'Cott' + end if + sq = chax(92) + if (abs(offnsk) .gt. .0001) then +c +c Write offset for floating figure, to two decimal places +c + notexq = sq//'off{' + if (-offnsk .lt. -9.995) then + write(notexq(6:11),'(f6.2)')-offnsk + lnote = 11 + else if (-offnsk.lt.-.995 .or. -offnsk.gt.9.995) then + write(notexq(6:10),'(f5.2)')-offnsk + lnote = 10 + else if (-offnsk.lt.-.0001 .or. -offnsk.gt..995) then + write(notexq(6:9),'(f4.2)')-offnsk + lnote = 9 + else + write(notexq(6:8),'(f3.2)')-offnsk + lnote = 8 + end if + notexq = notexq(1:lnote)//sq//'noteskip}' + call addstr(notexq,lnote+10,soutq,lsout) + end if + figq = figqq(ivx,ifig) + ic = 1 +c nof = 0 +c nofa = -1 + nof = -ivupfig(ivx,ifig) + nofa = -ivupfig(ivx,ifig)-1 +c +c Beginning of manual loop +c +1 ch1q = figq(ic:ic) +c +c Exit when first blank is encountered +c + if (ch1q .eq. ' ') go to 2 +c +c Starting a level. Set up vertical offset. +c +c lnof = 1 +c nofq = chax(nof+48) +c if (nof .gt. 9) then +c lnof = 2 +c nofq = '1'//chax(nof-10+48) +c end if +c if (nofa .eq.-1) then +c lnofa = 2 +c nofaq = '-1' +c else if (nofa .lt. 10) then +c lnofa = 1 +c nofaq = chax(nofa+48) +c else +c lnofa = 2 +c nofaq = '1'//chax(nofa+38) +c end if + call istring(nof,nofq,lnof) + call istring(nofa,nofaq,lnofa) + if (ch1q .eq. '0') then +c +c Continuation figure. Next number is length (in noteskips). The number will +c end at the first blank or char that is not digit or decimal point. If +c colon, it is a separator and must be skipped +c + icnum = ic+1 +3 continue + ic = ic+1 + if (index('0123456789.',figq(ic:ic)) .gt. 0) go to 3 + lnum = ic-icnum + call addstr(sq//Conttq//nofq(1:lnof)//'{' + * //figq(icnum:ic-1)//'}',7+ic-icnum+lnof,soutq,lsout) + if (figq(ic:ic) .ne. ':') ic=ic-1 + else if (ch1q.eq.'#'.or.ch1q.eq.'-'.or.ch1q.eq.'n') then + ic = ic+1 + ch2q = figq(ic:ic) + if (ch2q .eq. ' ') then +c +c Figure is a stand-alone accidental, so must be centered +c + if (ch1q .eq. '#') then + call addstr(sq//Figutq//nofaq(1:lnofa)// + * '{'//sq//'sharpfig}',16+lnofa,soutq,lsout) + else if (ch1q .eq. '-') then + call addstr(sq//Figutq//nofaq(1:lnofa)// + * '{'//sq//'flatfig}',15+lnofa,soutq,lsout) + else if (ch1q .eq. 'n') then + call addstr(sq//Figutq//nofaq(1:lnofa)// + * '{'//sq//'natfig}',14+lnofa,soutq,lsout) + end if + go to 2 + else +c +c Figure is an accidental followed by a number +c First put the accidental (offset to the left) +c + if (ch1q .eq. '#') then + call addstr(sq//Figutq// + * nofaq(1:lnofa)//'{'//sq//'fsmsh}', + * 13+lnofa,soutq,lsout) + else if (ch1q .eq. '-') then + call addstr(sq//Figutq// + * nofaq(1:lnofa)//'{'//sq//'fsmfl}', + * 13+lnofa,soutq,lsout) + else if (ch1q .eq. 'n') then + call addstr(sq//Figutq// + * nofaq(1:lnofa)//'{'//sq//'fsmna}', + * 13+lnofa,soutq,lsout) + end if +c +c Now put the number +c + call addstr(sq//Figutq//nofq(1:lnof)//'{'//ch2q//'}', + * 8+lnof,soutq,lsout) + endif + else if (ch1q .eq. '_') then +c +c Placeholder only (for lowering a figure). Don't do anything! +c + continue + else +c +c Figure is a single number, maybe with s after +c + call addstr(sq//Figutq//nofq(1:lnof)//'{', + * 6+lnof,soutq,lsout) + ch2q = figq(ic+1:ic+1) + if (ch2q .eq. 's') then +c +c Use a special character. Insert font call +c + ic = ic+1 + call addstr(sq//'ligfont',8,soutq,lsout) + end if + call addstr(ch1q//'}',2,soutq,lsout) +c call addstr(sq//Figutq//nofq(1:lnof)//'{'//ch1q//'}', +c * 8+lnof,soutq,lsout) + end if + if (ic .ge. 10) go to 2 + ic = ic+1 + nof = nof+4 + nofa = nofa+4 + go to 1 +2 continue + if (abs(offnsk) .gt. .0001) then + notexq = sq//'off{' + if (offnsk .lt. -9.995) then + write(notexq(6:11),'(f6.2)')offnsk + lnote = 11 + else if (offnsk.lt.-.995 .or. offnsk.gt.9.995) then + write(notexq(6:10),'(f5.2)')offnsk + lnote = 10 + else if (offnsk.lt.-.0001 .or. offnsk.gt..995) then + write(notexq(6:9),'(f4.2)')offnsk + lnote = 9 + else + write(notexq(6:8),'(f3.2)')offnsk + lnote = 8 + end if + notexq = notexq(1:lnote)//sq//'noteskip}' + call addstr(notexq,lnote+10,soutq,lsout) + end if + if (ifig .lt. nfigs(ivx)) then + ifig = ifig+1 + else + nfigs(ivx) = 0 + figcheck = .false. + end if + return + end + subroutine putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx, + * ncm,islur,nvmx,nv,ihornb,stemlin,outq,lout,ip,islhgt, + * beamon,iscrd) +c +c All args are individual array element *values* except nornb,ihornb,ulq. +c notcrd = .true. if ornament is on main note. +c nolevm is level of main note (for chords) +c + parameter (nm=24) + character*1 ulpzq,ulq(nm,9),udqq,sq,chax + character*8 noteq + character*79 notexq,outq + integer*4 ihornb(nm,24),nornb(nm) + logical btest,iscrd,usehornb,beamon + common /comivxudorn/ivxudorn(63) + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + sq = chax(92) + lout = 0 + usehornb = .false. + if (nodur .lt. 64) then + stemlen = stemlin + else + stemlen = 0. + end if +c +c Get up-downness. ulpzq is opposite from stem direction for both beams and +c non beams. Can use in name of ornament [ . or _ ] +c + if (beamon) then + if (ulq(ivx,ibmcnt) .eq. 'u') then + ulpzq = 'l' + else + ulpzq = 'u' + end if + else + if (udqq(nolevm,ncm,islur,nvmx,ivx,nv).eq.'l' ) then + ulpzq = 'u' + else + ulpzq = 'l' + end if + end if +c +c To enable >1 ornament on a note, next line is top of manual loop. +c +2 continue +c +c Bit # of last ornament (last of bits 0-21) +cc Bit # of last ornament (last of bits 0-24) + ibit = log2(iand(iornq,4194303)) +c ibit = log2(iand(iornq,33554431)) + iornt = 2**ibit +c +c Begin routine to set height. Bits 0-13: (stmgx+Tupf._) +c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n +c 19-20: >^, 21: ? (with or w/o 16-18) +c +c Do not use beam height for . or _ +c + if (btest(iornq,22) .and. iand(iornt,6144).eq.0) then +c +c Height is set by special beam stuff. +c Do not leave ihorn set, do separately for every ornament +c + ihorn = ihornb(ivx,nornb(ivx)) + if (ulpzq .eq. 'u') ihorn = ihorn-2 +c +c Following flag tells whether to increment nornb when exiting the subroutine. +c + usehornb = .true. + else if (ibit .eq. 14) then +c +c Down fermata. Don't worry about upper chord notes. +c + if (ulpzq .eq. 'l') then + ihorn = min(nolev,ncm-3) + else + ihorn = min(nolev-stemlen,ncm-3.) + end if + else if (btest(iornt,13) .or. btest(iornt,0)) then +c +c ( or ) +c + ihorn = nolev + else if (iand(iornt,6144) .gt. 0) then +c +cc Staccato . or tenuto _ , but not special beam stuff. Need up-down info +c NOTE: removed .&_ from special beam treatment. +c Staccato . or tenuto _ Need up-down info +c + if (.not.iscrd .or. (maxlev.ne.nolev.and.ulpzq.eq.'l') .or. + * (minlev.ne.nolev.and.ulpzq.eq.'u')) then + ihorn = nolev + else if (maxlev .eq. nolev) then + ulpzq = 'u' + ihorn = max(nolev+stemlen,ncm+3.) + else + ulpzq = 'l' + ihorn = min(nolev-stemlen,ncm-3.) + end if + else if (iscrd .and. nolev .eq. minlev) then + if (ulpzq .eq. 'l') then + ihorn = min(nolev-3,ncm-6) + else + ihorn = min(nolev-nint(stemlen)-3,ncm-6) + end if + else if (ibit.eq.10 .and. nolev.gt.90) then +c +c Special treatment for fermata on a shifted rest +c + ihorn = ncm+5 + else if (ulpzq.eq.'l') then +c +c (iscrd and nolev=maxlev) or (.not.iscrd) +c + ihorn = max(nolev+stemlen+2,ncm+5.) + else + ihorn = max(nolev+2,ncm+5) + end if + ioff = 0 + iclracc = 0 +c +c Begin routine to set name. Bits 0-13: (stmgx+Tupf._) +c 14: Down fermata, was F 15: Trill w/o "tr", was U, 16-18: edit. s,f,n +c + if (btest(iornt,2)) then + notexq = sq//'shake' + lnote = 6 + else if (btest(iornt,3)) then + notexq = sq//'mordent' + lnote = 8 + else if (btest(iornt,1)) then + notexq = sq//'mtr' + lnote = 4 + else if (btest(iornt,5)) then + notexq = sq//'xtr' + lnote = 4 + else if (btest(iornt,6)) then + notexq = sq//'ptr' + lnote = 4 + else if (btest(iornt,13)) then + notexq = sq//'rpn' + lnote = 4 + else if (btest(iornt,0)) then + notexq = sq//'lpn' + lnote = 4 + else if (btest(iornt,12)) then + notexq = sq//ulpzq//'st' + lnote = 4 + else if (btest(iornt,11)) then + notexq = sq//ulpzq//'pz' + lnote = 4 + else if (btest(iornt,8)) then + notexq = sq//'upz' + lnote = 4 + ioff = -2 + else if (btest(iornt,9)) then + notexq = sq//'uppz' + lnote = 5 + ioff = -2 + else if (btest(iornt,10)) then + if (nodur .lt. 48) then + notexq = sq//'fermataup' + else + notexq = sq//'Fermataup' + end if + lnote = 10 + ioff = -2 + else if (btest(iornt,14)) then + if (nodur .lt. 48) then + notexq = sq//'fermatadown' + else + notexq = sq//'Fermatadown' + end if + lnote = 12 + else if (btest(iornt,21)) then +c +c "?" in editorial ornament. Clear bit 16-18 after use, since ibit=21 +c + if (btest(iornq,16)) then + notexq = sq//'qsharp' + lnote = 7 + ioff = 2 + iornq = ibclr(iornq,16) + iclracc = 16 + else if (btest(iornq,17)) then + notexq = sq//'qflat' + lnote = 6 + ioff = 1 + iornq = ibclr(iornq,17) + iclracc = 17 + else if (btest(iornq,18)) then + notexq = sq//'qnat' + lnote = 5 + ioff = 2 + iornq = ibclr(iornq,18) + iclracc = 18 + else + notexq = sq//'qedit' + lnote = 6 + ioff = 0 + end if + else if (btest(iornt,16)) then + notexq = sq//'esharp' + lnote = 7 + ioff = 2 + else if (btest(iornt,17)) then + notexq = sq//'eflat' + lnote = 6 + ioff = 1 + else if (btest(iornt,18)) then + notexq = sq//'enat' + lnote = 5 + ioff = 2 + else if (btest(iornt,19)) then + notexq = sq//'usf' + lnote = 4 + ioff = -2 + else if (btest(iornt,20)) then + notexq = sq//'usfz' + lnote = 5 + ioff = -2 + end if + iudorn = 0 +c +c User-defined level shift of ornament from default? +c + if (btest(iornq,25)) then +c +c Find which (if any) element of kudorn has the shift. +c + do 3 iudorn = 1 , nudorn + if (ibit .lt. 21) then + ibitt = ibit +c +c Could have oes, but not oe? or oes? +c + else if (iclracc .gt. 0) then +c +c Earlier cleared edit. accid, meaning it was oes? +c + ibitt = iclracc+6 + else + ibitt = 21 + end if + ibitt=ip+ishft(mod(ivx,16),8)+ishft(nolev,12)+ishft(ibitt,19) +c if (ibitt .eq. iand(33554431,kudorn(iudorn))) go to 4 + if (ibitt .eq. iand(33554431,kudorn(iudorn)) + * .and. ivx.eq.ivxudorn(iudorn)) go to 4 +3 continue +c +c Nothing shifted on this note; exit this if block +c + iudorn = 0 + go to 5 +4 continue + ioffinc = iand(63,ishft(kudorn(iudorn),-25))-32 + if (ibit.eq.19 .and. ioffinc .lt. -7) then +c +c Convert usf to lsf. The reason has to do with positioning being impossile +c for some mysterious reason when you drop \usf below the staff +c + notexq = sq//'lsf' + ioffinc = ioffinc+6 + end if + ioff = ioff+ioffinc + end if +5 continue +c +c Shift level to avoid slur. Conditions are +c 1. There is a slur +c 2. No user-defined orn height shift (btest(iornq,25)) +c 3. upslur (islhgt>0) +c 4. ornament is not segno(4), ._)(11-13), down ferm(14) or "(" (0) Bin=30737 +c 5. islhgt+3 >= height already computed. +c + if (.not.btest(iornq,25) .and. + * islhgt.gt.0 .and. iand(iornt,30737).eq.0) + * ioff = ioff+dim(islhgt+3,ihorn ) + call notefq(noteq,lnoten,ihorn+ioff,ncm) + if (lnoten.eq.1) call addblank(noteq,lnoten) + if (iand(iornt,32896) .gt. 0) then +c +c T-trill or trill w/o "tr" +c + call dotrill(ivx,ip,iornt,noteq,lnoten,notexq,lnote) + else + notexq = notexq(1:lnote)//noteq(1:lnoten) + lnote = lnote+lnoten + end if + if (iudorn .gt. 0) then + if (btest(kudorn(iudorn),31)) then +c +c Horizontal shift +c + lform = lfmt1(ornhshft(iudorn)) + write(noteq(1:lform),'(f'//chax(48+lform)//'.1)') + * ornhshft(iudorn) + notexq = sq//'roffset{'//noteq(1:lform)//'}{' + * //notexq(1:lnote)//'}' + lnote = lnote+lform+12 + ornhshft(iudorn) = 0. + kudorn(iudorn) = ibclr(kudorn(iudorn),31) + end if + end if +c +c Zero out the bit for ornament just dealt with. +c + iornq = ibclr(iornq,ibit) + if (lout .eq. 0) then + outq = notexq(1:lnote) + else + outq = outq(1:lout)//notexq(1:lnote) + end if + lout = lout+lnote +c +c Check bits 0-21, go back if any are still set +c + if (iand(iornq,4194303) .gt. 0) go to 2 + if (usehornb) nornb(ivx) = nornb(ivx)+1 + return + end + subroutine putshft(ivx,onoff,soutq,lsout) + parameter (nm=24) + common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm) + character*80 soutq,notexq + character*1 sq,chax + logical onoff + sq = chax(92) +c +c Start user-defined offsets X(...): or X(...)S +c + if (onoff) nudoff(ivx) = nudoff(ivx)+1 +c +c Xoff is in pts. Round off to nearest .1. Will use at end of shift. +c + xoff = udoff(ivx,nudoff(ivx)) + xoff = sign(int(10.*abs(xoff)+.5)/10.,xoff) + if (.not.onoff) xoff = -xoff + if (xoff .lt. -9.95) then + ifmt = 5 + else if (xoff.lt.-.95 .or. xoff.gt.9.95) then + ifmt = 4 + else + ifmt = 3 + end if + write(notexq,'(f'//chax(48+ifmt)//'.1)')xoff + call addstr(sq//'off{'//notexq(1:ifmt)//'pt}',8+ifmt, + * soutq,lsout) + return + end + subroutine puttitle(inhnoh,xnsttop,etatop,sq,etait,etatc, + * etacs1,nv,vshrink,sepsymq) +c +c Called once per page, at top of page! If vshrink, only called for p.1. +c Actual titles only allowed on p.1. (set by headlog). +c 3/18/01: The above comment is probably bogus...can use Tt on later pages. +c + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip, + * inhead + common /cominbot/ inbothd + character*127 notexq + character*120 instrq,titleq,compoq + parameter (nm=24) + character*1 sq,sepsymq(nm),chax + logical headlog,vshrink + notexq = sq//'znotes' + lenline = 7 + do 22 iv = 1 , nv-1 + notexq = notexq(1:lenline)//sepsymq(iv) + lenline = lenline+1 +22 continue + notexq = notexq(1:lenline)//sq//'zcharnote{' + lenline = lenline+11 + if (.not.headlog) then + inhead = inhnoh + end if + if (vshrink .and. usevshrink) then + inhead = 16 + end if + ndig = int(alog10(inhead+.01))+1 + write(notexq(lenline+1:lenline+ndig+10),'(i'//chax(48+ndig)// + * ',a10)')inhead,'}{'//sq//'titles{' + lenline = lenline+ndig+10 +c +c Vertical skip at top of page (\Il) = etatop*glueil. Needed whether +c headers are present or not. +c + glueil = xnsttop/etatop + vskil = etatop*glueil + if (vshrink .and. usevshrink) vskil = 2 + call writflot(vskil,notexq,lenline) + if (.not.headlog) then + if (islast) write(11,'(a)')notexq(1:lenline) + * //'}{}{0}{}{0}{}{0}}'//sq//'en%' + else + notexq = notexq(1:lenline)//'}{' + lenline = lenline+2 + lcq = lenstr(instrq,120) + if (lcq .gt. 0) then + xitil = etait*glueil + if (vshrink .and. usevshrink) xitil = 2 + notexq = notexq(1:lenline)//instrq(1:lcq)//'}{' +c +c Null out instrument once used +c + instrq = ' ' + lenline = lenline+lcq+2 + call writflot(xitil,notexq,lenline) + else + notexq = notexq(1:lenline)//'}{0' + lenline = lenline+3 + end if + if (islast) write(11,'(a)')notexq(1:lenline)//'}%' + notexq = '{' + lenline = 1 + lcq = lenstr(titleq,120) + if (lcq .gt. 0) then + notexq = notexq(1:lenline)//titleq(1:lcq) + lenline = lenline+lcq + else + call printl(' ') + call printl('WARNING') + call printl( + * ' In a title block, you have specified instrument and/or') + call printl( + * ' composer but no title for the piece.') + end if + notexq = notexq(1:lenline)//'}{' + lenline = lenline+2 + xtcil = etatc*glueil + lcq = lenstr(compoq,120) + if (lcq .eq. 0) xtcil = 2*xtcil + if (vshrink .and. usevshrink) xtcil = 2 + call writflot(xtcil,notexq,lenline) + notexq = notexq(1:lenline)//'}{' + lenline = lenline+2 + if (lcq .gt. 0) then + notexq = notexq(1:lenline)//compoq(1:lcq)//'}{' + lenline = lenline+2+lcq +c +c Null out compoq so it does not get written later +c + compoq = ' ' + xcsil = etacs1*glueil + if (vshrink .and. usevshrink) xcsil = 2 + call writflot(xcsil,notexq,lenline) + else + notexq = notexq(1:lenline)//'}{0' + lenline = lenline+3 + end if + if (islast) write(11,'(a)')notexq(1:lenline)//'}}'//sq//'en%' + headlog = .false. + end if + return + end + subroutine putxtn(ntupv,iflop,multb,iud,wheadpt,poenom, + * nolev1,islope,slfac,xnlmid,islur,lnote,notexq,ncmid,nlnum, + * eloff,iup,irest,usexnumt) +c +c Places digit for xtuplet. +c + character*1 chax + character*8 noteq + character*79 notexq + logical btest,usexnumt + if (iflop.ne.0 .and. multb.gt.0) then +c +c Number goes on beam side, move R/L by .5 wheadpt for upper/lower +c + eloff = eloff-0.5*iud*wheadpt/poenom +c +c Number goes on beam side, must use beam parameters to set pos'n +c + nlnum = nolev1+islope/slfac*eloff+iup*(multb+8) + if (multb .ge. 2) nlnum = nlnum+iup + else + nlnum = nint(xnlmid-1+3*iud+iflop*11) + end if + if (.not.btest(islur,31)) then +c +c Only print number when wanted. First check vert, horiz offset +c + if (btest(irest,1)) nlnum = nlnum+iand(31,ishft(irest,-2))-16 + if (btest(irest,7)) eloff = eloff+ + * (.1*iand(31,ishft(irest,-9))-1.6)*wheadpt/poenom + if (.not.usexnumt) then + notexq = chax(92)//'xnum{' + lnote = 10 + istrtn = 7 + else + notexq = chax(92)//'xnumt{' + lnote = 11 + istrtn = 8 + end if + if (eloff .lt. 0.995) then + write(notexq(istrtn:istrtn+3),'(i1,f3.2)')0,eloff + else if (eloff .lt. 9.995) then + write(notexq(istrtn:istrtn+3),'(f4.2)')eloff + else + write(notexq(istrtn:istrtn+4),'(f5.2)')eloff + lnote = lnote+1 + end if + call notefq(noteq,lnoten,nlnum,ncmid) + notexq = notexq(1:lnote)//'}'//noteq(1:lnoten) + lnote = lnote+1+lnoten + if (ntupv .lt. 10) then + write(notexq(lnote+1:lnote+1),'(i1)')ntupv + lnote = lnote+1 + else + notexq = notexq(1:lnote)//'{' + write(notexq(lnote+2:lnote+3),'(i2)')ntupv + notexq = notexq(1:lnote+3)//'}' + lnote = lnote+4 + end if + end if + return + end + subroutine read10(string,lastchar) + parameter (maxblks=4000) + character*65536 bufq + integer*2 lbuf(maxblks) + common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq + character*(*) string + character*128 lnholdq + logical lastchar + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac + if (.not.mplay) then + if (ilbuf .gt. nlbuf) go to 999 + call getbuf(string) + return +999 lastchar = .true. + return + else +c +c Play a macro. Set pointer to first character needed in buffer +c + if (ilmac .eq. il1mac(macnum)) then +c +c Getting first line of macro +c + ip1 = ip1mac(macnum) + iplmac = ip1-ic1mac(macnum) + else if (ilmac .le. il2mac(macnum)) then +c +c Beyond first line of macro. Advance line-start pointer. +c + iplmac = iplmac+lbuf(ilmac-1) + ip1 = iplmac+1 + else +c +c Beyond last line of macro. Terminate it! +c + mplay = .false. + endmac = .true. + return + end if + if (ilmac .eq. il2mac(macnum)) then +c +c Getting last line of macro. +c + ip2 = ip2mac(macnum) + else +c +c Getting line before last line of macro. +c + ip2 = iplmac+lbuf(ilmac) + end if + if (ip2 .ge. ip1) then + string = bufq(ip1:ip2) + else +c +c Kluge for when macro start is on a line by itself +c + string = ' ' + end if + ilmac = ilmac+1 + return + end if + end + function readin(lineq,iccount,nline) +c +c Reads a piece of setup data from file lineq, gets a new lineq from +c file 10 (jobname.pmx) and increments nline if needed, passes over +c comment lines +c + character*128 lineq + character*1 durq,chax +4 if (iccount .eq. 128) then +1 call getbuf(lineq) + nline = nline+1 + if (lineq(1:1) .eq. '%') go to 1 + iccount = 0 + end if + iccount = iccount+1 +c +c Find next non-blank or end of line +c + do 2 iccount = iccount , 127 + if (lineq(iccount:iccount) .ne. ' ') go to 3 +2 continue +c +c If here, need to get a new line +c + iccount = 128 + go to 4 +3 continue +c +c iccount now points to start of number to read +c + i1 = iccount +5 call getchar(lineq,iccount,durq) +c +c Remember that getchar increments iccount, then reads a character. +c + if (index('0123456789.-',durq) .gt. 0) go to 5 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + call stop1() + end if + icf = i2-i1+49 + read(lineq(i1:i2),'(f'//chax(icf)//'.0)')readin + return + end + subroutine readmeter(lineq,iccount,mtrnum,mtrden) + character*128 lineq + character*1 durq,chax + if (index(lineq(iccount+1:iccount+3),'/') .eq. 0) then +c +c No slashes, so use old method +c + call getchar(lineq,iccount,durq) + if (durq .eq. '-') then +c +c Negative numerator is used only to printed; signals vertical slash +c + call getchar(lineq,iccount,durq) + mtrnum = -(ichar(durq)-48) + else if (durq .eq. 'o') then +c +c Numerator is EXACTLY 1 +c + mtrnum = 1 + else + mtrnum = ichar(durq)-48 + if (mtrnum .eq. 1) then +c +c Numerator is >9 +c + call getchar(lineq,iccount,durq) + mtrnum = 10+ichar(durq)-48 + end if + end if + call getchar(lineq,iccount,durq) + if (durq .eq. 'o') then + mtrden = 1 + else + mtrden = ichar(durq)-48 + if (mtrden .eq. 1) then + call getchar(lineq,iccount,durq) + mtrden = 10+ichar(durq)-48 + end if + end if + else +c +c Expect the form m[n1]/[n2]/[n3]/[n4] . Advance iccount by one from '/' or 'm' +c + iccount = iccount+1 + ns = index(lineq(iccount:128),'/') + read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrnum +c +c Reset iccount to start of second integer +c + iccount = iccount+ns +c +c There must be either a slash or a blank at pos'n 2 or 3 +c + ns = index(lineq(iccount:iccount+2),'/') + if (ns .eq. 0) ns = index(lineq(iccount:iccount+2),' ') + read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrden +c +c Set iccount to last character used +c + iccount = iccount+ns-1 + end if + return + end + subroutine readnum(lineq,iccount,durq,fnum) +c +c This reads a number starting at position iccount. Remember that on exit, +c getchar leaves iccount at the last character retrieved. So must only +c call this routine *after* detecting a number or decimal. +c On exit, durq is next character after end of number. +c + character*128 lineq + character*1 durq,chax + i1 = iccount +1 call getchar(lineq,iccount,durq) + if (index('0123456789.',durq) .gt. 0) go to 1 + i2 = iccount-1 + if (i2 .lt. i1) then + print*,'Found "'//durq//'" instead of number' + call stop1() + else if (lineq(i1:i1).eq.'.'.and.lineq(i2:i2).eq.'.') then + i2 = i2-1 + iccount = iccount-1 + end if + icf = i2-i1+49 + read(lineq(i1:i2),'(f'//chax(icf)//'.0)')fnum + return + end + subroutine setbits(isdata,iwidbit,ishift,ivalue) +c +c Sets iwidbits of isdata, shifted by ishift, to ivalue +c + ibase = 2**iwidbit-1 + if (ivalue.gt.ibase) then + print* + print*,'WARNING in setbits: ivalue > ibase' + write(15,'(/,a)')'WARNING in setbits: ivalue > ibase' + end if + isdata = iand(not(ishft(ibase,ishift)),isdata) + isdata = ior(isdata,ishft(ivalue,ishift)) + return + end + subroutine setbm2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1) +c +c The MEAN SQUARE slope algorithm +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk, + * isfig + real*4 xelsk(24) + integer ipb(24) + ibc = ibmcnt(ivx) + sumxx = 0. + sumxy = 0. + do 2 inb = 1 , nnb + sumxx = sumxx+xelsk(inb)**2 + sumxy = sumxy+xelsk(inb)*nolev(ivx,ipb(inb)) +2 continue + delta = nnb*sumxx-sumx*sumx + em = (nnb*sumxy-sumx*sumy)/delta + islope = nint(0.5*em*slfac) + if (iabs(islope) .gt. 9) islope = isign(9,islope) + beta = (sumy-islope/slfac*sumx)/nnb + nolev1 = nint(beta) +c +c Check if any stems are too short +c + smin = 100. + iul = -1 + if (ulq(ivx,ibc) .eq. 'u') iul = 1 + do 4 inb = 1 , nnb + ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac + ynote = nolev(ivx,ipb(inb)) + smin = min(smin,iul*(ybeam-ynote)) +4 continue + if (smin .lt. stemmin) then + deficit = stemmin-smin + nolev1 = nint(nolev1+iul*deficit) + end if + return + end + subroutine setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq, + * ivx,nline) + character*1 charq,durq + common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac + logical mrecord,mplay,endmac,btest + character*128 lnholdq,lineq + common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20), + * ic1mac(20),ilmac,iplmac +c +c Macro action +c + call g1etchar(lineq,iccount,charq) + if (charq.eq.'S' .and. ivx.ne.1) then + print* + print* + print*,'*********WARNING*********' + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * '"MS..." only put in parts by scor2prt if in voice #1!') + end if + if (index('RSP ',charq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Illegal character after "M" (macro)!') + call stop1() + else if (charq .ne. ' ') then +c +c Record or playback a macro. Get the number of the macro. +c + call g1etchar(lineq,iccount,durq) + if (index('123456789',durq) .eq. 0) then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Must input number after "MR","MP", or "MS"!') + call stop1() + end if + call readnum(lineq,iccount,durq,fnum) + macnum = nint(fnum) + if (durq .ne. ' ') then + call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, + * 'Macro number must be followed by a blank!') + call stop1() + end if + if (index('RS',charq ).gt. 0) then +c +c Record or save a macro +c + if (macnum.lt.1 .or. macnum.gt.20) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Macro number not in range 1-20!') + call stop1() +c else if (btest(macuse,macnum)) then +c print* +c print*,'WARNING: Redefining macro # ',macnum + end if + macuse = ibset(macuse,macnum) + if (charq .eq. 'R') then + call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) + else if (charq .eq. 'S') then +c +c Save (Record but don't activate) +c +1 call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm) + if (mrecord) then + call getbuf(lineq) + nline = nline+1 + iccount = 0 + go to 1 + end if + iccount = iccount+ndxm+1 + end if + else +c +c Playback the macro +c + if (.not.btest(macuse,macnum)) then + call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, + * 'Cannot play a macro that has not been recorded!') + call stop1() + end if + icchold = iccount + lnholdq = lineq + iccount = 128 + mplay = .true. + ilmac = il1mac(macnum) + end if + end if + return + end + subroutine setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep) +c +c Sets last 2 args depending on 1st 2, (logical) num, denom. +c ibmtyp = 1, 2, or 3 defines set of masks for beam groupings. +c 1: all duple meters +c 2: triple w/ denom=4, subdivide in groups of 2 8ths +c 3: triple w/ denom=8, subdivide in groups of 3 8ths +c Note that lenbar is set at top or when 'm' symbol is read in getnote +c + if (mtrdenl .eq. 4) then + if (mod(mtrnuml,3) .eq. 0) then + ibmtyp = 2 + ibmrep = mtrnuml/3 + else + ibmtyp = 1 + ibmrep = mtrnuml/2 + end if + else if (mtrdenl .eq. 2) then + ibmtyp = 1 + if (mtrnuml .eq. 3) then + ibmrep = 3 + else + ibmrep = 2*mtrnuml/mtrdenl + end if + else +c +c Assumes mtrdenl=8 and 3/8, 6/8, 9/8, or 12/8 +c + ibmtyp = 3 + ibmrep = mtrnuml/3 + end if +c +c Reset so we don't keep writing new meters +c + mtrnuml = 0 +c +c Prevent ibmrep=0. Needed for odd bars, e.g. 1/8, where beams don't matter +c + ibmrep = max(ibmrep,1) + return + end + subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest) +c +c The outer combo algorithm +c + parameter (nm=24) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + common /comipl2/ ipl2(nm,200) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,btest, + * isfig,vxtup,l1ng,l2ng,bar1syst,drawbm + common /comeskz2/ eskz2(nm,200) + real*4 slope(800),xelsk(24) + integer ipb(24) + common /comask/ bar1syst,fixednew,scaldold, + * wheadpt,fbar,poenom + common /comas1/ naskb,task(40),wask(40),elask(40) + common /comxtup/ ixtup,vxtup(nm),ntupv(nm,9),nolev1(nm), + * mtupv(nm,9),nxtinbm(nm), + * islope(nm),xels11(24),eloff(nm,9), + * nssb(nm),issb(nm),lev1ssb(nm,20) + common /comdraw/ drawbm(nm) + common /combmh/ bmhgt,clefend + common /commvl/ nvmx(nm),ivmx(nm,2),ivx + common /comtol/ tol + ibc = ibmcnt(ivx) + nxtinbm(ivx) = 0 + n1 = ipl2(ivx,ibm1(ivx,ibc)) +c +c Initialize counters used in this subroutine, and then later during actual +c beam drawing, to count later segments of single-slope beam groups +c + nssb(ivx) = 0 + issb(ivx) = 0 +c +c Set flag for xtup beam starting with rest (no others can start with rest) +c + if (btest(irest(ivx,ipo(n1)),0)) ixrest = 1 +c +c Figure how many elemskips to each note. Use the list, counting only non-rests. +c + eskz0 = eskz(ivx,ibm1(ivx,ibc)) + nnb = 0 + sumx = 0. + sumy = 0. + ipxt1 = 0 + iplast = ibm2(ivx,ibc) + do 2 ip = ibm1(ivx,ibc) , iplast + if (.not.btest(irest(ivx,ip),0)) then + nnb = nnb+1 + ipb(nnb) = ip + xelsk(nnb) = eskz(ivx,ip)-eskz0 + sumx = sumx+xelsk(nnb) + sumy = sumy+nolev(ivx,ipb(nnb)) + if (btest(nacc(ivx,ip),21)) then +c +c This is the starting note of later segment of single-slope beam group +c Temporarily store ip here. +c + nssb(ivx) = nssb(ivx)+1 + lev1ssb(ivx,nssb(ivx)) = nnb + end if + end if +c +c New xtup stuff here. Final object is to get distance from start of xtup +c to number. xtinbm counts xtups in this beam only. mtupv is the printed +c number. ntupv is number of notes in xtup, and is only used to get +c eloff, the distance from start of xtup to the number. +c + if (btest(nacc(ivx,ip),18)) ndoub = ndoub+1 + if (ipxt1.eq.0 .and. nodur(ivx,ip).eq.0) then +c +c Xtup is starting here +c + nxtinbm(ivx) = nxtinbm(ivx)+1 + ipxt1 = ip + if (btest(nacc(ivx,ip),18)) then + ndoub = 1 + else + ndoub = 0 + end if + else if (ipxt1.gt.0 .and. nodur(ivx,ip).gt.0) then +c +c Xtup ends here. Set total number of notes in xtup. +c + ntupv(ivx,nxtinbm(ivx)) = ip+1-ipxt1 +c +c Set printed number for embedded xtup. +c + mtupv(ivx,nxtinbm(ivx)) = ntupv(ivx,nxtinbm(ivx))+ndoub +c +c Middle note of xtup if ntupv odd, note to left of gap if even. +c + ipxtmid = (ip+ipxt1)/2 + eloff(ivx,nxtinbm(ivx)) = eskz2(ivx,ipxtmid)-eskz2(ivx,ipxt1) + if (mod(ntupv(ivx,nxtinbm(ivx)),2) .eq. 0) + * eloff(ivx,nxtinbm(ivx)) = eloff(ivx,nxtinbm(ivx))+ + * .5*(eskz2(ivx,ipxtmid+1)-eskz2(ivx,ipxtmid)) + ipxt1 = 0 + end if +2 continue +c +c Reset nxtinbm for use as counter as #'s are posted by putxtn(..) +c + nxtinbm(ivx) = 0 + smed = 0. + if (.not.btest(islur(ivx,ipb(1)),2)) then +c +c No forced 0 slope +c + if (nnb .eq. 1) go to 6 + nsc = 0 + do 5 inb = 1 , nnb-1 + do 5 jnb = inb+1 , nnb + nsc = nsc+1 + slope(nsc) = (nolev(ivx,ipb(jnb))-nolev(ivx,ipb(inb)))/ + * (xelsk(jnb)-xelsk(inb)) + if (abs(slope(nsc)) .lt. 1.e-4) then + nsc = nsc+1 + slope(nsc) = slope(nsc-1) + nsc = nsc+1 + slope(nsc) = slope(nsc-1) + end if +5 continue + if (nsc .eq. 1) then + smed = slope(1) + go to 6 + end if + nscmid = nsc/2+1 + do 7 i = 1 , nscmid + do 7 j = i+1 , nsc + if (slope(j) .lt. slope(i)) then + t = slope(j) + slope(j) = slope(i) + slope(i) = t + end if +7 continue + smed = slope(nscmid) + if (nsc .eq. 2*(nsc/2)) then +c +c Even number of slopes in the list, so median is ambiguous +c + if (abs(slope(nscmid-1)) .lt. abs(slope(nscmid))-tol) then +c +c Lower-numbered one is truly less in absolute value, so use it +c + smed=slope(nscmid-1) + else if (abs(slope(nscmid-1)+slope(nscmid)) .lt. tol) then +c +c Two slopes are effectively equal. Take the one with sign of the average +c + sum = 0. + do 1 i = 1 , nsc + sum = sum+slope(i) +1 continue + smed = sign(smed,sum) + end if + end if +6 continue + islope(ivx) = nint(0.5*smed*slfac) + if (iabs(islope(ivx)) .gt. 9) + * islope(ivx) = isign(9,islope(ivx)) + else +c +c Forced horizontal beam +c + islope(ivx) = 0 + end if + beta = (sumy-islope(ivx)/slfac*sumx)/nnb +c +c If ixrest>0, this is a virtual nolev1 at location of rest. Will first use +c as is for placing xtup number and/or bracket, then reset it for start of +c actual beam +c + nolev1(ivx) = nint(beta) +c +c Check if any stems are too short +c + smin = 100. + iul = -1 + if (ulq(ivx,ibc) .eq. 'u') iul = 1 + ssq = 0. + syb = 0. +c yb1 = nolev1(ivx)+iul*(stemlen+bmhgt*(mult(ivx,ipb(1))-1)) + yb1 = nolev1(ivx) + * +iul*(stemlen+bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1)) + do 4 inb = 1 , nnb + ybeam = yb1+islope(ivx)*xelsk(inb)/slfac +c * -iul*bmhgt*(mult(ivx,ipb(inb))-1) + * -iul*bmhgt*(iand(15,mult(ivx,ipb(inb)))-8-1) + syb = syb+ybeam + ynote = nolev(ivx,ipb(inb)) + off = ybeam-ynote + if (inb .eq. 1) then + off1 = off + else if (inb .eq. nnb) then + off2 = off + end if + ssq = ssq+off*off + smin = min(smin,iul*off) +4 continue + dnolev = 0. + if (smin .lt. stemmin) then + deficit = stemmin-smin + nolevo = nolev1(ivx) + nolev1(ivx) = nint(nolev1(ivx)+iul*deficit) + dnolev = nolev1(ivx)-nolevo + off1 = off1+dnolev + off2 = off2+dnolev + end if + ssq = ssq+2*dnolev*(syb-sumy)+dnolev**2 + if (.not.vxtup(ivx) .and. sqrt(ssq/nnb) .gt. stemmax .and. + * (abs(off1).lt.stemmax .or. abs(off2).lt.stemmax) + * .and. .not.btest(islur(ivx,ipb(1)),2)) then +c +c The first check is to save trouble of putting xtup's in setbm2. +c The penultimate check is that first and last stems aren't both excessive. +c The last check is that a 0 slope has not been forced +c + call setbm2(xelsk,nnb,sumx,sumy,ipb,islope(ivx),nolev1(ivx)) + end if +c +c Check if beam starts or ends too high or low. +c +c xboff = bmhgt*(mult(ivx,ipb(1))-1) + xboff = bmhgt*(iand(15,mult(ivx,ipb(1)))-8-1) + l1ng = iul*(nolev1(ivx)-ncmid(iv,ipb(1)))+xboff+7 .lt. 0. + xnolev2 = nolev1(ivx)+islope(ivx)/slfac*xelsk(nnb) + l2ng = iul*(xnolev2-ncmid(iv,ipb(nnb)))+xboff+7 .lt. 0 + if (l1ng .or. l2ng) then +c +c Need to correct start or stop, also slope +c + if (l1ng) then + nolev1(ivx) = nint(ncmid(iv,ipb(1))-(7.+xboff)*iul) + end if + if (l2ng) then + xnolev2 = nint(ncmid(iv,ipb(nnb))-(7.+xboff)*iul) + end if +c +c Since one or the other end has changed, need to change slope +c + if (.not.btest(islur(ivx,ipb(1)),2)) + * islope(ivx) = nint(slfac*(xnolev2-nolev1(ivx))/xelsk(nnb)) + end if + if (nssb(ivx) .gt. 0) then +c +c This is a single-slope beam group. Store start heights for later segs. +c + do 3 issbs = 1 , nssb(ivx) + lev1ssb(ivx,issbs) = nolev1(ivx)+islope(ivx)/slfac* + * xelsk(lev1ssb(ivx,issbs)) +3 continue + end if + return + end + subroutine sortpoe(nsyst,poe,ipoe) + parameter (nks=125) + real*4 poe(nks) + integer*4 ipoe(nks) +c +c Initialize ipoe: +c + do 3 iord = 1 , nsyst + ipoe(iord) = iord +3 continue +c +c Construct ipoe vector with pairwise interchanges. When done, ipoe(1) will +c be index of smallest poe, and ipoe(nsyst) will be index of biggest poe. +c + do 4 io1 = 1 , nsyst-1 + do 5 io2 = io1+1 , nsyst + if (poe(ipoe(io1)) .gt. poe(ipoe(io2))) then +c +c Interchange the indices +c + itemp = ipoe(io1) + ipoe(io1) = ipoe(io2) + ipoe(io2) = itemp + end if +5 continue +4 continue + return + end + subroutine spsslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3, + * isdat4,nsdat,notcrd,nolev,starter) + parameter (nm=24) +c +c Reads in slur data. Record all h/v-shifts for non-chords, user-specified +c ones for chords. +c 5/26/02 This subr is called ONLY for postscript slurs. +c +c See subroutine doslur for bit values in isdat1,2,3 +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + integer*4 isdat1(202),isdat2(202),isdat3(202),isdat4(202) + logical notcrd,btest + character*128 lineq + character*1 durq,dumq,starter + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical upslur,fontslur,WrotePsslurDefaults +c +c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve +c + numint = 0 + ivoff = 0 + ihoff = 0 + nsdat = nsdat+1 + if (starter.eq.'{' .or. starter.eq.'}') + * isdat2(nsdat)=ibset(isdat2(nsdat),3) + call setbits(isdat1(nsdat),5,13,iv) + call setbits(isdat1(nsdat),1,12,kv-1) + call setbits(isdat1(nsdat),8,3,ip) + isdat3(nsdat) = 0 + isdat4(nsdat) = 0 + ilb12 = 0 ! flag for tweaks of 1st or 2nd (0|1) seg of linebreak slur +c +c Get ID code +c + call getchar(lineq,iccount,durq) + if (index('uldtb+-hfnHps ',durq) .gt. 0) then +c +c Null id. Note for ps slurs, 'H' cannot be an ID +c + iccount = iccount-1 + if (lineq(iccount:iccount) .eq. 't') then + idcode = 1 + else + idcode = 32 + end if + else +c +c Set explicit idcode +c + idcode = ichar(durq) + if (lineq(iccount-1:iccount-1) .eq. 't') then +c +c Make t[ID] look like s[ID]t +c + isdat2(nsdat) = ibset(isdat2(nsdat),3) + end if + end if + call setbits(isdat1(nsdat),7,19,idcode) +c +c Set start/stop: look thru list from end for same idcode,iv,kv +c + do 2 isdat = nsdat-1 , 1 , -1 + if (idcode .eq. igetbits(isdat1(isdat),7,19) .and. + * iv .eq. igetbits(isdat1(isdat),5,13) .and. + * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then +c +c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0. +c + if (btest(isdat1(isdat),11)) go to 3 +c +c Found slur is a turnoff, so new one is a turnon. Jump down to set bit +c + go to 4 + end if +2 continue +c +c If here, this is turnon. +c +4 continue + isdat1(nsdat) = ibset(isdat1(nsdat),11) +3 continue +c +c Now done with initial turnon- or turnoff-specifics. +c + if (nint(SlurCurve).ne.0 .and. btest(isdat1(nsdat),11)) then +c +c There's a default curvature tweak +c + icurv1 = nint(SlurCurve)+3 + if (icurv1 .eq. 2) icurv1 = 1 + isdat3(nsdat) = ibset(isdat3(nsdat),0) + call setbits(isdat3(nsdat),6,2,32+icurv1) + end if +c +c Loop for rest of input +c +1 call getchar(lineq,iccount,durq) + if (index('uld',durq) .gt. 0) then +c +c Force direction +c + isdat1(nsdat) = ibset(isdat1(nsdat),26) + if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27) + go to 1 + else if (index('+-',durq) .gt. 0) then + numint = numint+1 + if (numint .eq. 1) then +c +c Vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 + ivoff = nint(fnum) + if (durq .eq. '-') ivoff = -ivoff + else if (numint .eq. 2) then +c +c Horizontal offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 +c +c fnum is abs(hshift), must be 0 to 6.3 +c + ihoff = fnum*10 + .5 + if (durq .eq. '-') ihoff = -ihoff +c +c Later will set bits to 1...127 to represent -6.3,...+6.3 +c + else +c +c Must be the 3rd signed integer, so it's a curve specification +c + isdat3(nsdat) = ibset(isdat3(nsdat),0) + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + icurv1 = nint(fnum) + if (durq .eq. '-') icurv1 = -icurv1 + call setbits(isdat3(nsdat),6,2,32+icurv1) + if (dumq .ne. ':') then +c +c Back up the pointer and loop for more input +c + iccount = iccount-1 + else +c +c Expect two single digits as parameters for curve +c + isdat3(nsdat) = ibset(isdat3(nsdat),1) + call setbits(isdat3(nsdat),3,8, + * ichar(lineq(iccount+1:iccount+1))-48) + call setbits(isdat3(nsdat),3,11, + * ichar(lineq(iccount+2:iccount+2))-48) + iccount = iccount+2 + end if + end if + go to 1 + else if (durq .eq. 't') then + isdat2(nsdat) = ibset(isdat2(nsdat),3) + go to 1 + else if (durq .eq. 'b') then + isdat2(nsdat) = ibset(isdat2(nsdat),4) + go to 1 + else if (durq .eq. 's') then +c +c Endpoint tweaks for linebreak slurs. +c + call getchar(lineq,iccount,durq) ! Must be +|- +c +c Next is vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + if (durq .eq. '-') fnum=-fnum + call setbits(isdat4(nsdat),6,ilb12*16,nint(fnum)+32) + if (index('+-',dumq) .gt. 0) then +c +c Also a horizontal offset +c + iccount = iccount+1 + call readnum(lineq,iccount,durq,fnum) + if (dumq .eq. '-') fnum=-fnum + call setbits(isdat4(nsdat),7,ilb12*16+6,nint(10*fnum)+64) + end if + iccount = iccount-1 + ilb12 = 1 + go to 1 + else if (index('fnhH',durq).gt.0) then +c +c Special ps slur curvatures. +c Translate to old \midslur args (1,4,5,6) +c + icurv1 = index('fnxhH',durq) + if (icurv1 .eq. 5) then +c +c check for 2nd H +c + if (lineq(iccount+1:iccount+1) .eq. 'H') then + iccount = iccount+1 + icurv1 = 6 + end if + end if + isdat3(nsdat) = ibset(isdat3(nsdat),0) + call setbits(isdat3(nsdat),6,2,32+icurv1) + go to 1 + else if (durq .eq. 'p') then ! Local adjustment + call getchar(lineq,iccount,durq) ! +|- + call getchar(lineq,iccount,dumq) ! s|t +c 26 \sluradjust (p+s) +c 27 \nosluradjust (p-s) +c 28 \tieadjust (p+t) +c 29 \notieadjust (p-t) + if (durq .eq. '+') then + if (dumq .eq. 's') then + isdat2(nsdat) = ibset(isdat2(nsdat),26) + else + isdat2(nsdat) = ibset(isdat2(nsdat),28) + end if + else + if (dumq .eq. 's') then + isdat2(nsdat) = ibset(isdat2(nsdat),27) + else + isdat2(nsdat) = ibset(isdat2(nsdat),29) + end if + end if + go to 1 + end if +c +c Record shifts +c + call setbits(isdat2(nsdat),6, 6,ivoff+32) + call setbits(isdat2(nsdat),7,12,ihoff+64) +c +c Record chord flag, note level, notehead shift +c + if (notcrd) then + call setbits(isdat2(nsdat),7,19,nolev) + else + nolevc = igetbits(icrdat(ncrd),7,12) + call setbits(isdat2(nsdat),7,19,nolevc) + isdat2(nsdat) = ibset(isdat2(nsdat),0) + call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23)) + end if + return + end + subroutine sslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3, + * nsdat,notcrd,nolev,starter) + parameter (nm=24) +c +c Reads in slur data. Record all h/v-shifts for non-chords, user-specified +c ones for chords. +c 5/26/02 now only for non-postscript slurs, use spsslur() for postscript +c +c See subroutine doslur for bit values in isdat1,2,3 +c + common /comtrill/ ntrill,ivtrill(24),iptrill(24),xnsktr(24), + * ncrd,icrdat(193),icrdot(193),icrdorn(193),nudorn, + * kudorn(63),ornhshft(63),minlev,maxlev,icrd1,icrd2 + integer*4 isdat1(202),isdat2(202),isdat3(202) + logical notcrd,btest + character*128 lineq + character*1 durq,dumq,starter + common /comslur/ listslur,upslur(nm,2),ndxslur,fontslur + * ,WrotePsslurDefaults,SlurCurve + logical upslur,fontslur,WrotePsslurDefaults +c +c Counter for signed integers. 1st is height, 2nd is horiz, 3rd is curve +c + numint = 0 + ivoff = 0 + ihoff = 0 + nsdat = nsdat+1 + if (starter.eq.'{' .or. starter.eq.'}') + * isdat2(nsdat)=ibset(isdat2(nsdat),3) + call setbits(isdat1(nsdat),5,13,iv) + call setbits(isdat1(nsdat),1,12,kv-1) + call setbits(isdat1(nsdat),8,3,ip) + isdat3(nsdat) = 0 +c +c Get id letter +c + if (lineq(iccount:iccount) .eq. 't') then +c +c Old-style t-slur. Use special idcode = 1 +c + idcode = 1 + else + call getchar(lineq,iccount,durq) + if (index('uldtb+-hf ',durq) .gt. 0) then +c +c Null id +c + idcode = 32 + iccount = iccount-1 + else if (durq.eq.'H') then +c +c Postscript slur, cannot use 'H' as code, must check for 2nd 'H' +c + idcode = 32 + iccount = iccount-1 +c +c There may be another "H", but no need to deal with it yet +c + else +c +c Set explicit idcode +c + idcode = ichar(durq) + end if + end if + call setbits(isdat1(nsdat),7,19,idcode) +c +c Set start/stop: look thru list from end for same idcode,iv,kv +c + do 2 isdat = nsdat-1 , 1 , -1 + if (idcode .eq. igetbits(isdat1(isdat),7,19) .and. + * iv .eq. igetbits(isdat1(isdat),5,13) .and. + * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then +c +c Matched idcode & ivx. On/off?. If on, new is turnoff, leave bit 11 at 0. +c + if (btest(isdat1(isdat),11)) go to 3 +c +c Found slur is a turnoff, so new one is a turnon. Jump down to set bit +c + go to 4 + end if +2 continue +c +c If here, this is turnon. +c +4 continue + isdat1(nsdat) = ibset(isdat1(nsdat),11) +3 continue +c +c Now done with initial turnon- or turnoff-specifics. Loop for rest of input +c +1 call getchar(lineq,iccount,durq) + if (index('uld',durq) .gt. 0) then +c +c Force direction +c + isdat1(nsdat) = ibset(isdat1(nsdat),26) + if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27) + go to 1 + else if (index('+-',durq) .gt. 0) then + numint = numint+1 + if (numint .eq. 1) then +c +c Vertical offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 + ivoff = nint(fnum) + if (durq .eq. '-') ivoff = -ivoff + else if (numint .eq. 2) then +c +c Horizontal offset +c + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + iccount = iccount-1 +c +c fnum is abs(hshift), must be 0 to 6.3 +c + ihoff = fnum*10 + .5 + if (durq .eq. '-') ihoff = -ihoff +c +c Later will set bits to 1...127 to represent -6.3,...+6.3 +c + else +c +c Must be the 3rd signed integer, so it's a curve specification +c + isdat3(nsdat) = ibset(isdat3(nsdat),0) + iccount = iccount+1 + call readnum(lineq,iccount,dumq,fnum) + icurv1 = nint(fnum) + if (durq .eq. '-') icurv1 = -icurv1 + call setbits(isdat3(nsdat),6,2,32+icurv1) + if (dumq .ne. ':') then +c +c Back up the pointer and loop for more input +c + iccount = iccount-1 + else +c +c Expect two single digits as parameters for curve +c + isdat3(nsdat) = ibset(isdat3(nsdat),1) + call setbits(isdat3(nsdat),3,8, + * ichar(lineq(iccount+1:iccount+1))-48) + call setbits(isdat3(nsdat),3,11, + * ichar(lineq(iccount+2:iccount+2))-48) + iccount = iccount+2 + end if + end if + go to 1 + else if (durq .eq. 't') then + isdat2(nsdat) = ibset(isdat2(nsdat),3) + go to 1 + else if (durq .eq. 'b') then + isdat2(nsdat) = ibset(isdat2(nsdat),4) + go to 1 + else if (index('fhH',durq) .gt. 0) then +c +c Special ps slur curvatures. Translate to old \midslur args (1,4,5,6) +c + icurv1 = 2+index('fhH',durq) + if (icurv1 .eq. 3) then + icurv1 = 1 + else if (icurv1 .eq. 5) then +c +c check for 2nd H +c + if (lineq(iccount+1:iccount+1) .eq. 'H') then + iccount = iccount+1 + icurv1 = 6 + end if + end if + isdat3(nsdat) = ibset(isdat3(nsdat),0) +c +c Must change sign if downslur, but cannot do it now since we don't know +c slur direction for sure. +c + call setbits(isdat3(nsdat),6,2,32+icurv1) + go to 1 + end if +c +c Record shifts +c + call setbits(isdat2(nsdat),6, 6,ivoff+32) + call setbits(isdat2(nsdat),7,12,ihoff+64) +c +c Record chord flag, note level, notehead shift +c + if (notcrd) then + call setbits(isdat2(nsdat),7,19,nolev) + else + nolevc = igetbits(icrdat(ncrd),7,12) + call setbits(isdat2(nsdat),7,19,nolevc) + isdat2(nsdat) = ibset(isdat2(nsdat),0) + call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23)) + end if + return + end + subroutine stop1() + call exit(1) + end + subroutine topfile(basenameq,lbase,nv,clefq,noinst,musicsize, + * xinstf1,mtrnmp,mtrdnp,vshrink,fbar,fontslur) + parameter (nm=24) + common /comlast/ islast,usevshrink + logical islast,usevshrink,fontslur + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + common /comarp/ narp,tar(8),ivar1(8),ipar1(8),levar1(8),ncmar1(8), + * xinsnow,lowdot + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + character*79 inameq + character*44 basenameq + character*24 fmtq + character*5 fbarq + character*1 clefq(nm),sq,chax + common /comstart/ facmtr + logical vshrink,lowdot,rename + logical novshrinktop,cstuplet + common /comnvst/ novshrinktop,cstuplet + common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), + * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans + logical EarlyTransOn,LaterInstTrans + common /comsize/ isize(nm) + sq = chax(92) + vshrink = xinstf1.gt.20. .and. .not.novshrinktop + if (vshrink) then + xinsnow = 10. + else + xinsnow = xinstf1 + end if + if (.not.islast) return + write(11,'(a)')'%%%%%%%%%%%%%%%%%' + write(11,'(a)')'%' + write(11,'(a)')'% '//basenameq(1:lbase)//'.tex' + write(11,'(a)')'%' + write(11,'(a)')'%%%%%%%%%%%%%%%%' + write(11,'(a)')sq//'input musixtex' + write(11,'(a)')sq//'input pmx' +c write(11,'(a)')sq//'input musixmad' +c write(11,'(a)')sq//'input musixxad' + write(11,'(a)') + * sq//'setmaxslurs{24}'//sq//'setmaxinstruments{24}%' + if (.not.fontslur) write(11,'(a)')sq//'input musixps' +c +c Need to input musixmad to permit more slurs. +c + if (musicsize .eq. 20) then + write(11,'(a)')sq//'normalmusicsize%' + else if (musicsize .eq. 16) then + write(11,'(a)')sq//'smallmusicsize%' + else if (musicsize .eq. 24) then + write(11,'(a)')sq//'largemusicsize%' + write(11,'(a)')sq//'def'//sq//'meterfont{'//sq// + * 'meterlargefont}%' + else if (musicsize .eq. 29) then + write(11,'(a)')sq//'Largemusicsize%' + write(11,'(a)')sq//'def'//sq//'meterfont{'//sq// + * 'meterLargefont}%' + end if +c +c Set sizes. Have sizes per staff in isize(.) and noinst per staff in +c nsperi(.) +c + iiv = 1 + do 5 iinst = 1 , noinst + if (isize(iiv) .eq. 1) then + if(iinst.le.9) then + write(11,'(a8,i1,a)') + * sq//'setsize',iinst,sq//'smallvalue%' + else + write(11,'(a9,i2,a)') + * sq//'setsize{',iinst,'}'//sq//'smallvalue%' + end if + else if (isize(iiv) .eq. 2) then + if(iinst.le.9) then + write(11,'(a8,i1,a)') + * sq//'setsize',iinst,sq//'tinyvalue%' + else + write(11,'(a9,i2,a)') + * sq//'setsize{',iinst,'}'//sq//'tinyvalue%' + end if + end if + iiv = iiv+nsperi(iinst) +5 continue +c +c do 5 iiv = 1 , nv +c if (isize(iiv) .eq. 1) then +c if(iiv.le.9) then +c write(11,'(a8,i1,a)') +c * sq//'setsize',iiv,sq//'smallvalue%' +c else +c write(11,'(a9,i2,a)') +c * sq//'setsize{',iiv,'}'//sq//'smallvalue%' +c end if +c else if (isize(iiv) .eq. 2) then +c if(iiv.le.9) then +c write(11,'(a8,i1,a)') +c * sq//'setsize',iiv,sq//'tinyvalue%' +c else +c write(11,'(a9,i2,a)') +c * sq//'setsize{',iiv,'}'//sq//'tinyvalue%' +c end if +c end if +c5 continue +c + write(fbarq,'(f5.3)')fbar + write(11,'(a)')sq//'nopagenumbers' + write(11,'(a)')sq//'tracingstats=2'//sq//'relax' + write(11,'(a7,i3,a2)')sq//'hsize=',nint(widthpt),'pt' + write(11,'(a6,i'//chax(49+int(log10(height+.1)))//',a2)') + * sq//'vsize',int(height+.1),'pt' + if (abs(hoffpt) .gt. 0.1) then + if (hoffpt .le. -10.) then + write(11,'(a8,i3,a2)')sq//'hoffset',nint(hoffpt),'pt' + else if (hoffpt .lt. 0.) then + write(11,'(a8,i2,a2)')sq//'hoffset',nint(hoffpt),'pt' + else if (hoffpt .lt. 10.) then + write(11,'(a8,i1,a2)')sq//'hoffset',nint(hoffpt),'pt' + else + write(11,'(a8,i2,a2)')sq//'hoffset',nint(hoffpt),'pt' + end if + end if + if (abs(voffpt) .gt. 0.1) then + if (voffpt .le. -10.) then + write(11,'(a8,i3,a2)')sq//'voffset',nint(voffpt),'pt' + else if (voffpt .lt. 0.) then + write(11,'(a8,i2,a2)')sq//'voffset',nint(voffpt),'pt' + else if (voffpt .lt. 10.) then + write(11,'(a8,i1,a2)')sq//'voffset',nint(voffpt),'pt' + else + write(11,'(a8,i2,a2)')sq//'voffset',nint(voffpt),'pt' + end if + end if +c +c The default raisebarno=3.5 internote, set in pmx.tex. Increase to 4.5 if +c 3 sharps and treble clef, to avoid vertical clash with top space g# +c + if (isig.eq.3 .and. clefq(nv).eq.'t') write(11,'(a)') + * sq//'def'//sq//'raisebarno{4.5'//sq//'internote}' + if (noinst .lt. 10) then + write(11,'(a19,i1,a1)')sq//'def'//sq//'nbinstruments{', + * noinst,'}' + else + write(11,'(a19,i2,a1)')sq//'def'//sq//'nbinstruments{', + * noinst,'}' + end if + iv = 0 + do 1 iinst = 1 , noinst + nstaves = nsperi(iinst) + if (iinst .lt. 10) then + write(11,'(a)')sq//'setstaffs'//chax(48+iinst) + * //chax(48+nstaves) + else + write(11,'(a11,i2,a)')sq//'setstaffs{',iinst,'}' + * //chax(48+nstaves) + end if + iv = iv+1 + if (nstaves .eq. 1) then + fmtq = chax(48+numclef(clefq(iv))) + lfmtq = 1 + else + fmtq = '{'//chax(48+numclef(clefq(iv))) + lfmtq = 2 + do 2 k = 2 , nstaves + iv = iv+1 + fmtq = fmtq(1:lfmtq)//chax(48+numclef(clefq(iv))) + lfmtq = lfmtq+1 +2 continue + fmtq = fmtq(1:lfmtq)//'}' + lfmtq = lfmtq+1 + end if + if (iinst .lt. 10) then + write(11,'(a)')sq//'setclef'//chax(48+iinst)//fmtq(1:lfmtq) + else + write(11,'(a9,i2,a)')sq//'setclef{',iinst,'}'//fmtq(1:lfmtq) + end if + do 3 lname = 79 , 2 , -1 + if (inameq(iinst)(lname:lname) .ne. ' ') go to 4 +3 continue +4 continue + lnam(iinst) = lname + if (iinst .lt. 10) then + write(11,'(a8,i1,a)')sq//'setname',iinst, + * '{'//inameq(iinst)(1:lname)//'}' + else + write(11,'(a9,i2,a)')sq//'setname{',iinst, + * '}{'//inameq(iinst)(1:lname)//'}' + end if +1 continue + write(11,'(a18,i2,a2)')sq//'generalsignature{',isig,'}%' + if (EarlyTransOn) + * call Writesetsign(nInstTrans,iInstTrans,iTransKey,EarlyTransOn) + call wgmeter(mtrnmp,mtrdnp) + ipi = nint(fracindent*widthpt) + if (ipi .lt. 10) then + write(11,'(a11,i1,a2)')sq//'parindent ',ipi,'pt' + else if (ipi .lt. 100) then + write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt' + else + write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt' + end if + write(11,'(a)')sq//'elemskip1pt'//sq//'afterruleskip' + * //fbarq//'pt'//sq//'beforeruleskip0pt'//sq//'relax' + if (.not.vshrink) then + if (xinstf1 .lt. 9.95) then + fmtq = '(a,f3.1,a)' + else + fmtq = '(a,f4.1,a)' + end if + write(11,fmtq)sq//'stafftopmarg0pt'//sq//'staffbotmarg0pt' + * //sq//'interstaff{',xinstf1,'}'//sq//'relax' + else + write(11,'(a)')sq//'stafftopmarg0pt'// + * sq//'staffbotmarg5'//sq//'Interligne'//sq// + * 'interstaff{10}'//sq//'relax' + end if + if (nv.eq.1) write(11,'(a)')sq//'nostartrule' + write(11,'(a)')sq//'readmod{'//basenameq(1:lbase)//'}' + if (cstuplet) then + write(11,'(a)')sq//'input tuplet' + * //sq//'def'//sq//'xnumt#1#2#3{'//sq//'zcharnote{#2}{~}' + * //sq//'def'//sq//'tuplettxt{'//sq//'smalltype'//sq//'it{#3}' + * //sq//'/'//sq//'/}}%' + write(11,'(a)')sq//'let'//sq//'ovbkt'//sq//'uptuplet' + * //sq//'let'//sq//'unbkt'//sq//'downtuplet%' + end if + write(11,'(a)')sq//'startmuflex'//sq//'startpiece'//sq// + * 'addspace'//sq//'afterruleskip%' + return + end + character*1 function udfq(nolev,ncm) +c +c Slur directions +c + common /combc/ bcspec + logical bcspec + ntest = nolev-ncm + if (ntest.lt.0 .or. + * (ntest.eq.0 .and. bcspec .and. ncm.eq.23) ) then + udfq = 'd' + else + udfq = 'u' + end if + return + end + character*1 function udqq(nole,ncm,isl,nvmx,ivx,nv) +c +c Stem direction for single notes +c + character*1 ulfq + character*1 udqqq + logical btest + if (btest(isl,30)) then +c +c Absolute override +c + if (btest(isl,17)) then + udqqq = 'u' + else + udqqq = 'l' + end if + else if (nvmx .eq. 1) then +c +c Single voice per staff, default +c + udqqq = ulfq(1.*nole,ncm) + else +c +c Multi-voice per staff, 1st is lower, 2nd upper +c + if (ivx .le. nv) then + udqqq = 'l' + else + udqqq = 'u' + end if + end if + udqq = udqqq + return + end + character*1 function ulfq(xnolev,ncm) +c +c Stem directions +c + common /combc/ bcspec + logical bcspec + test = xnolev-ncm + if (test.lt.-.001 .or. + * (test.lt..001.and.bcspec.and.ncm.eq.23) ) then + ulfq = 'u' + else + ulfq = 'l' + end if + return + end + function upcaseq(chq) + character*1 chq,upcaseq,chax + if (ichar(chq).ge.61.and.ichar(chq).lt.122) then + upcaseq = chax(ichar(chq)-32) + else + upcaseq = chq + print*,'Warning, upcaseq was called with improper argument: ' + * //chq + stop + end if + return + end + subroutine wgmeter(mtrnmp,mtrdnp) +c +c Writes meter stuff to file 11, so only called if islast=.true. +c + character*1 sq,chax + if (mtrdnp .eq. 0) return + sq=chax(92) + if (mtrnmp.gt.0 .and. mtrnmp.le.9) then + if (mtrdnp .lt. 10) then + write(11,'(a25,i1,a2,i1,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + else + write(11,'(a25,i1,a2,i2,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + end if + else if (mtrnmp .ge. 10) then + if (mtrdnp .lt. 10) then + write(11,'(a25,i2,a2,i1,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + else + write(11,'(a25,i2,a2,i2,a3)') + * sq//'generalmeter{'//sq//'meterfrac{', + * mtrnmp,'}{',mtrdnp,'}}%' + end if + else if (mtrnmp .lt. 0) then + write(11,'(a26,i1,a2,i1,a3)') + * sq//'generalmeter{'//sq//'meterfracS{', + * -mtrnmp,'}{',mtrdnp,'}}%' + else if (mtrdnp .le. 4) then + write(11,'(a21,i1,a2)') + * sq//'generalmeter{'//sq//'meterN',mtrdnp,'}%' + else if (mtrdnp .eq. 5) then + write(11,'(a)')sq//'generalmeter'//sq//'allabreve%' + else if (mtrdnp .eq. 6) then + write(11,'(a)')sq//'generalmeter'//sq//'meterC%' + else if (mtrdnp .eq. 7) then + write(11,'(a)')sq//'generalmeter'//sq//'meterIIIS%' + end if + return + end + subroutine writemidi(jobname,ljob) + parameter(nm=24,mv=24576) + common /all/ mult(nm,200),iv,nnl(nm),nv,ibar, + * ivxo(600),ipo(600),to(600),tno(600),tnote(600),eskz(nm,200), + * ipl(nm,200),ibm1(nm,9),ibm2(nm,9),nolev(nm,200),ibmcnt(nm), + * nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200), + * nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax, + * stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200), + * ifigdr(2,125),iline,figbass,figchk(2),firstgulp,irest(nm,200), + * iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202), + * isdat4(202),beamon(nm),isfig(2,200),sepsymq(nm),sq,ulq(nm,9) + character*1 ulq,sepsymq,sq + logical beamon,firstgulp,figbass,figchk,isfig + character*1 byteq(4),char,chax + character*10 tempoq,instq + character*44 jobname + integer*2 mmidi + logical restpend,relacc,notmain,twoline,ismidi,crdacc + common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(20),mgap, + * iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm), + * nmidcrd,midchan(nm,2),numchan,naccim(0:nm), + * laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain, + * restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv), + * debugmidi + logical debugmidi + common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) + * ,miditran(nm),midtc(0:nm) + common /comevent/ miditime,lasttime + logical mmacrec,gottempo + common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac, + * mmactime(20),nmidsec,msecstrt(0:nm,60),msecend(0:nm,60), + * mmacrec,gottempo + character*79 inameq + common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0, + * isig,lastisig,fracindent,widthpt,height,hoffpt,voffpt,idsig, + * lnam(nm),inameq(nm) + logical rename + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) +c +c Used to be icmm(0:nm); did midi fail when nv>16? +c + integer*2 iinsiv(nm),icmm(0:15) + character*5 versionc + common /comver/ versionc +c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13/ + data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/ +c Can't remember why these were not consecutive. +c data icmm /0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ +c +c Write Header +c + write(51,'(a,$)')'MThd'//char(0)//char(0)//char(0)//char(6) + * //char(0)//char(1)//char(0)//char(numchan+1)//char(0)//char(240) + if (debugmidi) + * write(52,'(a6,10Z4)')'"MThd"',0,0,0,6, + * 0,1,0,numchan+1,0,240 +c +c Write the "conductor" track, for keys, meter, and tempos +c Get the number of bytes in the conductor event stream +c + ndata = 1+imidi(numchan)-msecstrt(numchan,nmidsec) + do 15 isec = 1 , nmidsec-1 + ndata = ndata+1+msecend(numchan,isec)-msecstrt(numchan,isec) +15 continue +c ib1 = (4+ljob+26+ndata+4)/256 +c ib0 = 4+ljob+26+ndata+4-256*ib1 + ib1 = (4+ljob+27+ndata+4)/256 + ib0 = 4+ljob+27+ndata+4-256*ib1 + write(51,'(a,$)')'MTrk'//char(0)//char(0)//char(ib1)//char(ib0) +c +c Text header +c +c * //char(0)//char(255)//char(1)//char(ljob+26) + * //char(0)//char(255)//char(1)//char(ljob+27) + if (debugmidi) + * write(52,'(a6,8z4)')'"MTrk"',0,0,ib1,ib0, + * 0,255,1,ljob+27 + write(51,'(a,$)')jobname(1:ljob) + if (debugmidi) write(52,'(a)')'"'//jobname(1:ljob)//'"' +c +c (separate writes are needed to defeat compiler BUG!!!) +c +c write(51,'(a,$)')'.mid, produced by PMX 2.30' + write(51,'(a,$)')'.mid, produced by PMX '//versionc + if (debugmidi) write(52,'(a)') + * '".mid, produced by PMX '//versionc//'"' +c +c Conductor event data: Loop over sections. +c + do 16 isec = 1 , nmidsec + if (isec .lt. nmidsec) then + mend = msecend(numchan,isec) + else + mend = imidi(numchan) + end if + do 17 i = msecstrt(numchan,isec) , mend + write(51,'(a,$)')char(mmidi(numchan,i)) + if (debugmidi) write(52,'(z4)')mmidi(numchan,i) +17 continue +16 continue +c +c And close out the time sig / tempo track. +c + write(51,'(a,$)')char(0)//char(255)//char(2*16+15)//char(0) + if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0 +c +c Loop over track for each voice: The following sets up iv. +c + iv = nv + if (twoline(nv)) then + kv = 2 + else + kv = 1 + end if +c +c Count up staves(iv,nv) vs instruments. Store instr# for iv in iinsiv(iv) +c + nstaves = 0 + ivt = 0 + do 12 iinst = 1 , nm + nstaves = nstaves+nsperi(iinst) + do 13 ivtt = 1 , nsperi(iinst) + ivt = ivt+1 + iinsiv(ivt) = iinst +13 continue + if (nstaves .eq. nv) go to 14 +12 continue + print*,'Screwup!' + call stop1() +14 continue +c + do 5 icm = 0 , numchan-1 +c +c Get the number of bytes in the data stream +c + ndata = 1+imidi(icm)-msecstrt(icm,nmidsec) + do 11 isec = 1 , nmidsec-1 + ndata = ndata+1+msecend(icm,isec)-msecstrt(icm,isec) +11 continue +c +cc Add 3 (for instrum) plus 4 (for closing) to byte count, +c Add 3 for instrum, 4 for bal, plus 4 (for closing) to byte count, +c +c ndata = ndata+7 + ndata = ndata+11 +c +c Add 4+lnam(iinsiv(iv)) if lnam>0 , +c + if (lnam(iinsiv(iv)).gt.0) ndata = ndata+4+lnam(iinsiv(iv)) +c +c Separate total byte counts into 4 bytes +c + do 2 ibyte = 1 , 4 + if (ndata .gt. 0) then + byteq(ibyte) = char(mod(ndata,256)) + ndata = ishft(ndata,-8) + else + byteq(ibyte) = char(0) + end if +2 continue +c +c Now write front stuff for this track +c + write(51,'(a,$)')'MTrk'//byteq(4)//byteq(3)//byteq(2)//byteq(1) + * //char(0)//char(12*16+icmm(icm))//char(midinst(iv)) + * //char(0)//char(11*16+icmm(icm))//char(10)//char(midbc(icm)) + if (debugmidi) write(52,'(a4,z2,a7,11z4)')'icm=',icm, + * ' "MTrk"',ichar(byteq(4)),ichar(byteq(3)),ichar(byteq(2)), + * ichar(byteq(1)),0,12*16+icmm(icm),midinst(iv), + * 0,11*16+icmm(icm),10,midbc(icm) + if (lnam(iinsiv(iv)) .gt. 0) then +c +c Add instrument name as sequence name +c + write(51,'(a,$)')char(0)//char(255)//char(3) + * //char(lnam(iinsiv(iv))) + if (debugmidi) write(52,'(4z4)')0,255,3,lnam(iinsiv(iv)) + write(51,'(a,$)') + * inameq(iinsiv(iv))(1:lnam(iinsiv(iv))) + if (debugmidi) write(52,'(a)') + * '"'//inameq(iinsiv(iv))(1:lnam(iinsiv(iv)))//'"' + end if + write(tempoq,'(i2)')icm + write(instq,'(i3)')midinst(iv) + call printl('MIDI instrument '//tempoq(1:2)//' is '//instq(1:3)) +c +c Notes: Loop over sections. +c + do 9 isec = 1 , nmidsec + if (isec .lt. nmidsec) then + mend = msecend(icm,isec) + else + mend = imidi(icm) + end if + do 10 i = msecstrt(icm,isec) , mend + write(51,'(a,$)')char(mmidi(icm,i)) + if (debugmidi) write(52,'(z4)')mmidi(icm,i) +10 continue +9 continue +c +c Closing 4 bytes +c + write(51,'(a,$)')chax(0)//char(255)//char(2*16+15)//char(0) + if (debugmidi) write(52,'(4z4)')0,255,2*16+15,0 + if (kv .eq. 2) then + kv = 1 + else if (iv .eq. 1) then + go to 5 + else + iv = iv-1 + if (twoline(iv)) kv=2 + end if +5 continue + write(*,'(1x,a12,(10i6))')'Bytes used:',(imidi(icm),icm=0,numchan) + write(15,'(1x,a12,(10i6))') + * 'Bytes used:',(imidi(icm),icm=0,numchan) + close(51) + if (debugmidi) close(52) + return + end + subroutine Writesetsign(nInstTrans,iInstTrans,iTransKey,flag) + parameter(nm=24) + integer*4 iInstTrans(nm),iTransKey(nm) + character*79 notexq + character*1 chax + logical flag +c +c Assumes notexq is blank +c + do 1 i = 1 , nInstTrans + notexq = chax(92)//'setsign' + lnote = 8 + if (iInstTrans(i) .lt. 10) then + notexq = notexq(1:lnote)//chax(48+iInstTrans(i)) + lnote = lnote+1 + else + write(notexq(lnote+1:lnote+4),'(a1,i2,a1)') + * '{',iInstTrans(i),'}' + lnote = lnote+4 + end if + if (iTransKey(i) .lt. 0) then + write(notexq(lnote+1:lnote+4),'(a1,i2,a1)') + * '{',iTransKey(i),'}' + lnote = lnote+4 + else + notexq = notexq(1:lnote)//chax(48+iTransKey(i)) + lnote = lnote+1 + end if + write(11,'(a)')notexq(1:lnote)//'%' +1 continue + flag = .false. + return + end + subroutine writflot(x,notexq,lenline) + character*(*) notexq + if (x .lt. 0.95) then + write(notexq(lenline+1:lenline+2),'(f2.1)')x + lenline = lenline+2 + else if (x .lt. 9.95) then + write(notexq(lenline+1:lenline+3),'(f3.1)')x + lenline = lenline+3 + else + write(notexq(lenline+1:lenline+4),'(f4.1)')x + lenline = lenline+4 + end if + return + end + subroutine wsclef(iv,ninow,clefq,nclef) +c +c Writes \setclef for instrument containing voice iv +c + parameter (nm=24) + common /comlast/ islast,usevshrink + logical islast,usevshrink + common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) + logical rename + character*1 clefq(nm),chax + character*20 temq + if (nclef .lt. 7) then + clefq(iv) = chax(48+nclef) + else + clefq(iv)='9' + end if + if (.not.islast) return + iv1 = 1 + do 1 iinst = 1 , ninow + if (iv .lt. iv1+nspern(iinst)) go to 2 + iv1 = iv1+nspern(iinst) +1 continue + print* + print*,'Should not be here in wsclef!' + call stop1() +2 continue + iv2 = iv1+nspern(iinst)-1 + if (iinst .lt. 10) then + temq = chax(92)//'setclef'//chax(48+iinst) + ltem = 9 + else + write(temq,'(a9,i2,a1)') chax(92)//'setclef{',iinst,'}' + ltem = 12 + end if + if (iv1 .eq. iv2) then + write(11,'(a)')temq(1:ltem)//clefq(iv)//'%' + else + temq = temq(1:ltem)//'{' + ltem = ltem+1 + do 3 iiv = iv1 , iv2 + temq = temq(1:ltem)//chax(48+numclef(clefq(iiv))) + ltem = ltem+1 +3 continue + write(11,'(a)')temq(1:ltem)//'}%' + end if + return + end |