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 . 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.84 c Bug fix: dots in chordal seconds c Bug fix: Initialize ihornb for non-beamed, down xtup c Bug fix: When using "AT" with 2-note x3c rD. c 2.83 c Fix problems when changing to or from octave treble clef. c Fix beaming (or not) and number location for xtups with c multiple rests. Still some problems with number height but c can be band-aided with number height tweak option. c Tweak error messages for options on "R" command. c Allow forced beam height and slope tweaks with 2-note tremolos c Allow chordal note with 2-note tremolos, adding dots as needed. c Fix call to ncmid in beamstrt when setting start height for beam of c 2-note trem, by changing arg from ivx to iv c 2.82 c bugfix: beams with rests, not confused with xtups. c x option after slur index to allow slurs to go from one voice to another. c x option also for ties c 2.81 c Allow string of rests to end xtup c in chordal half-note 2-note tremolo, make chord notes open. c 2.80 c Add 2-note tremolos c 2.78 c Expand bufq to 131072 bytes c Expand maxblks tp 9600 c Allow up to 75 pages c Index postscript hairpins from 1 up instead of by voice #. c Add option 'o' to forced beam for open notehead (\hb); set ipl(3) c Add option T[n], n=1,2,3 for single stem tremolo c 2.77 c Enable AV+/-x+/-y to add vskip bigh before or after \eject c 2.76 c 2.75 c Bugfix: unbeamed xtups with dots: in beamn1 and beamid allow dotted 16th, and c 2 or 3 flags on shortened note. c 2.74 c Bugfix: allow "0" as argument of @ command on lyrics string. c Check for and allow "\ in centered page headings with P command. c Check for and allow "\ in text dynamics with D command. c For lyrics string starting in xtuplet, insert check for inputting musixlyr. c For staff-crossing beamed xtuplet chords, if 2nd segment of a joined beam c starts with a blank rest, put '\sk' into the TeX. c To enable high-to-both beamed etup staff-crossing chord, for blank c rest at start of forced beam, shift \sk's from before to after \ib..; c so \ib is at start and note in upper voice has a beam to connect to. c Expand range of vertical xtup number shift, now stored in mult(16-22) c Check for and allow \" within lyrics strings, for umlauts. c 2.73 (160121) c Dirk's "..." command, to convert "text" into \pmxlyr{text}\ and insert as c inline TeX. Replace all '~' inside "..." and not preceded with '\', by c '\lk '. Right after 2nd ", replace @[a,b][+,-]n with \at{[a,b][+,-]n}\ c Include definitions of \ly and \at in pmx.tex (2 Feb 16). After first ", c add (as type 2 string) '\\input musixlyr \' c After inputting pathname, change any '\' to '/', for Linux compatibility. c 2.72 (160110) c Really finalize \mbrest...go back to 3 args to deal with clef changes. c Fine tune centered whole bar rests to deal with clef changes c Fix bug in wsclef when >1 staff per instrument, since \setclef c needs to know instrument and specify clefs on all staves for that c instrument. Ones that were not changed by user will not be printed, c and will be kept the same as before. c Fix bug with arpegii from one voice to another in same staff. c 2.71 (151226) c Finalize mbrest mods c 2.705 c Fix error message c 2.704 (140614) c Octave treble clef c Make horizontal ornament shift (ornhshft) floating c 2.703 (140323) c Option v[-]n at end of any figure will alter figdrop for rest of system c 2.702 c Stem slurs. Only for ps, assume no other pos'n adjustments. Option "v" c 2.701 c oC = coda (\code{10}) c Move iornq(29) (blank barline) to ipl(0) (changes in pmxb, getnote) c oG = new seqno c To do: fix grace note spacing problem (partially done) c 2.622 c Redefine midtc(..) and miditran(..); clean up all transpositions/key changes c Kn[+/-...] \ignorenats at signature changes c Fix tie checks in doslur() and dopsslur() to subtract iTransAmt from nolevs c before checking and setting pitch levels levson() and levsoff() c Define midisig separately from isig. Put in common commidisig. c Use for explicit midi signature and for accid corrections to midi piches c in addmidi. c 2.621 c Make keyboard rest option work in xtuplets. Created subroutine c chkkbdrests, modified make2bar to include calls to chkkbdrests as rqd. c 2.620 c Allow user-defined rest height tweaks at start of beam. 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 / 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=9600) character*128 lnholdq character*131072 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),noinst,iinsiv(nm) integer*2 iinsiv 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 Added 130302 only to get nsperi from g1etnote, for use in midi setup c common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt, * fracindent,nsperi(nm),linesinpmxmod,line1pmxmod,lenbuf0 logical lastchar,fbon,issegno,isheadr,isvolt 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 /'10 Feb 18'/ data version /'2.84'/ 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 c call getarg(1,jobname,idum) ! May need to replace this w/ next line 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. c call getarg(2,jobname,idum) ! May need to replace this w/ next line 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.131072) 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 This was moved here from writemidi 130302 to allow midivel,bal,tran, to be c set up here as functions of instrument rather than iv (staff). c Count up staves(iv,nv) vs instruments. Store instr# for iv in iinsiv(iv) c nstaves = 0 ivt = 0 do 16 iinst = 1 , nm nstaves = nstaves+nsperi(iinst) do 17 ivtt = 1 , nsperi(iinst) ivt = ivt+1 iinsiv(ivt) = iinst 17 continue if (nstaves .eq. nv) go to 18 16 continue print*,'Screwup!' call stop1() 18 continue 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 c 130302 Make these functions of instrument rather than staff (iv) c midvelc(midchan(iv,2)) = midivel(iv) c midbc(midchan(iv,2)) = midibal(iv) c midtc(midchan(iv,2)) = miditran(iv) midvelc(midchan(iv,2)) = midivel(iinsiv(iv)) midbc(midchan(iv,2)) = midibal(iinsiv(iv)) midtc(midchan(iv,2)) = miditran(iinsiv(iv)) end if c midvelc(midchan(iv,1)) = midivel(iv) c midbc(midchan(iv,1)) = midibal(iv) c midtc(midchan(iv,1)) = miditran(iv) midvelc(midchan(iv,1)) = midivel(iinsiv(iv)) midbc(midchan(iv,1)) = midibal(iinsiv(iv)) midtc(midchan(iv,1)) = miditran(iinsiv(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 "/" and (2) next to last c line is "/" c if (bufq(iplast+1-lbuf(nlbuf):iplast) .eq. ' /') then if (bufq(iplast-lbuf(nlbuf):iplast-lbuf(nlbuf)).eq.'/') then print*,'Removing last line of "/"' write(15,*)'Removing last line of "/"' 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) 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 130330 start oldwask = 0. oldelask = 0. c 130330 end 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 c c 130330 We were double counting the larger space when it came 2nd c Need to fix but don't see how yet. Assume times came in order and c that last naskb defined spaces that need updating c oldwask = wask(naskb) oldelask = elask(naskb) c End of 130330 insertions naskb = naskb-1 else return end if end if naskb = naskb+1 task(naskb) = taskn wask(naskb) = waskn elask(naskb) = elaskn c 130330 start c fixednew = fixednew+waskn c scaldold = scaldold+elaskn fixednew = fixednew+waskn-oldwask scaldold = scaldold+elaskn-oldelask c 130330 end end if return end subroutine addblank(noteq,lnoten) character*8 noteq character*1 tchar tchar = noteq(1:1) 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 subroutine addmidi(icm,nolev,iacc,midisig,time,rest,endrest) 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),noinst,iinsiv(nm) integer*2 iinsiv 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 common /commidisig/ midisig(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 (midisig .ne. 0) then c c Adjust for signature c notenumq = char(48+mod(nolev,7)) if (midisig.ge.index('4152630',notenumq)) then ipsav = ipsav+1 else if (-midisig.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 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 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,istart,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) integer*4 istart(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 lnote = 0 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 c c Terminate indented beams for 2-note tremolo if needed c if (btest(irest(ivx,ip-1),2) .and. * igetbits(irest(ivx,ip-1),2,5) .gt. 0) then nindent = igetbits(irest(ivx,ip-1),2,5) if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then addoff = -1-.5*nindent else addoff = 1+.5*nindent endif c addoff = addoff+(.595-.065*abs(islope(ivx)))*islope(ivx) addoff = addoff+.0822*islope(ivx) if (addoff .lt. -.05) then write(tempq,'(f4.1)')addoff else write(tempq,'(f4.2)')addoff end if notexq = sq//'raise'//tempq(1:4)//sq//'internote'//sq//'hbox{' * //sq//'loffset{.7}{'//sq//'tb'//ulq(ivx,ibmcnt(ivx))// * '0}}' lnote = 46 end if if (.not.drawbm(ivx)) then c c Xtuplet with no beam, just put in the right kind of note c if (btest(irest(ivx,ip),0)) then c c Rest at end of unbeamed xtup c lnote = 3 if (btest(islur(ivx,ip),29)) then notexq = sq//'sk' c c 180106 There was a problem with nolev(ivx,ip) not being set to 0 for c a blank rest ending xtup, but hopefully returning from here will handle it. c return else if (multip .eq. 0) then notexq = sq//'qp' else if (multip .eq. -1) then notexq = sq//'hp' else if (multip .eq. 1) then notexq = sq//'ds' else if (multip .eq. 2) then notexq = sq//'qs' else notexq = sq//'hs' end if c c 180106 Deal with possible level tweak c nole = mod(nolev(ivx,ip)+50,100)-50 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' * //notexq(1:lnote) else notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote' * //notexq(1:lnote) end if lnote = 16+lnoten+lnote end if return end if 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) c c To reduce confusion due to this early update of lnote, do it c below, separately in each case/ c lnote = lnoten+3 if (.not.btest(nacc(ivx,ip-1),27)) then c c Prior note is not regular-dotted c if (btest(irest(ivx,ip-1),2) .and. * igetbits(irest(ivx,ip-1),2,5) .gt. 0) then c c Unbeamed tremolo with indented beams. Put termination in right here c nindent = igetbits(irest(ivx,ip-1),2,5) if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then addoff = -1-.5*nindent else addoff = 1+.5*nindent endif c c Is there an islope here, for unbeamed? c if (addoff .lt. -.05) then write(tempq,'(f4.1)')addoff else write(tempq,'(f4.2)')addoff end if notexq = sq//'raise'//tempq(1:4)//sq//'internote'//sq// * 'hbox{' * //sq//'loffset{.7}{'//sq//'tb'//ulq(ivx,ibmcnt(ivx))// * '0}}' lnote = 46 c write(11,'(a)')notexq(1:lnote) end if if (multip .eq. 0) then c if (btest(irest(ivx,ip-1),2)) then if (btest(irest(ivx,ip-1),2) .and. * nodur(ivx,ip).gt.24) then c c 2nd note of unbeamed half-note trem; make open c But it's not clear if unbeamed half-note tremolo is Kosher, c so don't worry about stem lengths here now. c if (lnote .eq. 0) then notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq else notexq = notexq(1:46)// * sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq lnote = 46 end if else if (btest(irest(ivx,ip-1),2) .and. * nodur(ivx,ip).eq.24 .or. nodur(ivx,ip).eq.12) then c c Need a dot. c lnote = 46 if (lnoten .eq. 1) then noteq = ' '//noteq(1:1) lnoten = 2 end if notexq = notexq(1:lnote)//sq//'pt'//noteq(1:lnoten) lnote = lnote+3+lnoten call notefq(noteq,lnoten,nole,ncmid(iv,ip)) if (lnoten .eq. 1) then noteq = ' '//noteq(1:1) lnoten = 2 end if c c Insert stemlength stuff here for unbeamed dotted tremolo. c May later combine with below to avoid repeat. But need to c return to normal stem length after note is set. c nindent = igetbits(irest(ivx,ip-1),2,5) if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then slen = (4.5+nindent+nolev1(ivx)-nole * +1.3*(eskz(ivx,ip)-eskz(ivx,ip-1)-.7) * *islope(ivx)/slfac)*.6667 else slen = (4.5+nindent-nolev1(ivx)+nole * -1.3*(eskz(ivx,ip)-eskz(ivx,ip-1)-.7) * *islope(ivx)/slfac)*.6667 end if write(tempq,'(f4.1)')slen notexq = sq//'slx{'//tempq//'}'//notexq(1:lnote) lnote = lnote+10 end if if (lnote .eq. 0) then notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) * //noteq(1:lnoten) else notexq = notexq(1:lnote)//sq//'q' * //ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten) end if lnote = lnote+3+lnoten if (btest(irest(ivx,ip-1),2) .and. * nodur(ivx,ip).eq.24 .or. nodur(ivx,ip).eq.12) then notexq = notexq(1:lnote)//sq//'slz' lnote=lnote+4 end if end if else if (btest(irest(ivx,ip-1),2)) then c c 2nd note of unbeamed quarter or 8th trem; make quarter note c Get stemlength change c lnote = 46 nindent = igetbits(irest(ivx,ip-1),2,5) if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then slen = (4.5+nindent+nolev1(ivx)-nole * +1.3*(eskz(ivx,ip)-eskz(ivx,ip-1)-.7) * *islope(ivx)/slfac)*.6667 else slen = (4.5+nindent-nolev1(ivx)+nole * -1.3*(eskz(ivx,ip)-eskz(ivx,ip-1)-.7) * *islope(ivx)/slfac)*.6667 end if write(tempq,'(f4.1)')slen notexq = notexq(1:46)//sq//'slx{'//tempq//'}' lnote = lnote+10 c if (lnote .eq. 0) then c notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq c else c notexq = notexq(1:46)// c * sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq c end if c c c Check for dotted unbeamed tremolo c if (abs(nodur(ivx,ip)/12.-nodur(ivx,ip)/12).lt..001) then c c Need a dot c if (lnoten .eq. 1) then noteq = ' '//noteq(1:1) lnoten = 2 end if if (lnote .eq. 0) then notexq = sq//'pt'//noteq(1:lnoten) else notexq = notexq(1:lnote)//sq//'pt'//noteq(1:lnoten) end if lnote = lnote+3+lnoten call notefq(noteq,lnoten,nole,ncmid(iv,ip)) if (lnoten .eq. 1) then noteq = ' '//noteq(1:1) lnoten = 2 end if end if notexq = notexq(1:lnote)// * sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten) c * //sq//'stemcut' * //sq//'slz' c lnote=lnote+3+lnoten+8 lnote=lnote+3+lnoten+4 else if (multip .eq. -1) then notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten) lnote = lnoten+3 else if (multip .eq. 1) then notexq = sq//'c'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten) lnote = lnoten+3 else if (multip .eq. 2) then notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten) lnote = lnoten+4 else if (multip .eq. 3) then notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx))//noteq(1:lnoten) lnote = lnoten+5 else if (multip .eq. -2) then notexq = sq//'wh'//noteq(1:lnoten) lnote = lnoten+3 else if (multip .eq. -3) then notexq = sq//'breve'//noteq(1:lnoten) lnote = lnoten+6 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 lnote = lnoten+3 end if end if return end if c c End of block for unbeamed. Problem if beamed but ends w/ rest. Try just c skipping the call in that case. c if (.not.btest(irest(ivx,ip),0)) then call notefq(noteq,lnoten,nole,ncmid(iv,ip)) end if c call notefq(noteq,lnoten,nole,ncmid(iv,ip)) c lnote = 0 c c New way, with flipend, which was computed in beamstrt. c if (flipend(ivx) .and. btest(ipl(ivx,ip),30)) then ulq(ivx,ibmcnt(ivx)) = chax(225-ichar(ulq(ivx,ibmcnt(ivx)))) flipend(ivx) = .false. end if 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 (170409) or rest at end of xtup c so some sort of termination is required c ulqq = ulq(ivx,ibmcnt(ivx)) if (.not.isbjmp .or. ivx.ne.ivbj2) then if (btest(irest(ivx,ip),0)) then c c Xtup ends with rest c if (multip .eq. 1) then notexq = sq//'ds' lnote = 3 else if (multip .eq. 2) then notexq = sq//'qs' lnote = 3 else if (multip .eq. 3) then notexq = sq//'hs' lnote = 3 end if c c 170801 Borrowed from main rest entry way down below to get level adjustment: c BUT nole is like 102, not 2, so subtracted 100 for nole. Why different??? c "... Now raise if necc." c if (btest(islur(ivx,ip),29)) then c c Blank rest c notexq = sq//'sk' lnote = 3 else if (nole .ne. 0) then c c Bandaid. Odd case with rests in xtups + 2 voices where came thru here with c nolev=-4 but expected 100+/-. Try to fix. c if (abs(nole).lt.30) nole = 100+nole c if (abs(nole-100) .lt. 10) then noteq = chax(48+abs(nole-100)) lnoten = 1 else write(noteq(1:2),'(i2)')abs(nole-100) lnoten = 2 end if c ??? if (nole .gt. 0) then if (nole .gt. 100) then notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote' * //notexq(1:lnote) else notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote' * //notexq(1:lnote) end if lnote = 16+lnoten+lnote end if return else c c Normal termination c call ntrbbb(1,'t',ulqq,mod(ivx,24),notexq,lnote) end if 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 Check for end of 2nd seg of staff-jump xtup chord blank rest c c if (isbjmp.and.ivx.eq.ivbj2 if (isbjmp * .and.btest(islur(ivx,ip),29)) then notexq = notexq(1:lnote)//sq//'sk' return end if c c And now the note, checking for open-head beamed tremolo c if (btest(irest(ivx,ip-1),2)) then c c Check for dotted tremolo c if (abs(nodur(ivx,ip)/12.-nodur(ivx,ip)/12).lt..001) then c c Need a dot c if (lnoten .eq. 1) then noteq = ' '//noteq(1:1) lnoten = 2 end if if (lnote .eq. 0) then notexq = sq//'pt'//noteq(1:lnoten) else notexq = notexq(1:lnote)//sq//'pt'//noteq(1:lnoten) end if lnote = lnote+3+lnoten call notefq(noteq,lnoten,nole,ncmid(iv,ip)) ! Octave changes? end if if (nodur(ivx,ip).eq.32 .or. nodur(ivx,ip).eq.48) then if (lnote .gt. 0) then notexq = notexq(1:lnote)//sq//'hb' else notexq = sq//'hb' end if else if (lnote .gt. 0) then notexq = notexq(1:lnote)//sq//'qb' else notexq = sq//'qb' end if end if else c c No tremolo c if (lnote .gt. 0) then notexq = notexq(1:lnote)//sq//'qb' else notexq = sq//'qb' end if 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 call istring(mod(ivx,24),tempq,len) else 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 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 of xtup 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 xtup note is regular dotted non-beamed xtup c notexq = notexq(1:3)//'p' lnote = 4 end if else c c Prior note of xtup is regular-dotted so this one is halved c if (multip .eq. 2) then notexq = sq//'ccc'//ulq(ivx,ibmcnt(ivx)) lnote = 5 else if (multip .eq. 1) then notexq = sq//'cc'//ulq(ivx,ibmcnt(ivx)) lnote = 4 else 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), * mult(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 for string of rests up to and including last note in xtup. c c Replace next 2 lines to keep from doing this block c when in second part of staff-jumping chordal xtup. This fix could c break some unaccounted non-chordal staff-jum xtup situations. c if (vxtup(ivx) .and. btest(irest(ivx,ip+1),0) .and. c * .not.btest(irest(ivx,ip),0)) then if (vxtup(ivx) .and. btest(irest(ivx,ip+1),0) .and. * .not.btest(irest(ivx,ip),0) .and. * .not.(isbjmp.and.ivx.eq.ivbj2)) then c c This note is not a rest but next is a rest. Do rests continue to c end of xtup, where nodur>0 c do 3 ipnow = ip+1 , ip+24 if (nodur(ivx,ipnow).gt.0) go to 4 ! This is last of xtup if (.not.btest(irest(ivx,ipnow+1),0)) go to 5 ! Next is not rest c c If I don't go to 5, know next note IS a rest! c 3 continue 4 continue call ntrbbb(1,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote) notexq = notexq(1:lnote)//sq//'qb' lnote = lnote+3 call istring(ivx,tempq,len) notexq = notexq(1:lnote)//tempq(1:len) lnote = lnote+len notexq = notexq(1:lnote)//noteq(1:lnoten) lnote = lnote+lnoten return 5 continue c c Check if multiplicity changes in a way requiring action, c unless (160211) it's blank rest on start of 2nd seg of joined beam c else if(.not.btest(irest(ivx,ip-1),24) * .or..not.btest(islur(ivx,ip-1),29)) then 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) c else if (multl .ge. multr) then c Test for next note being blank rest, assuming staff-crossing c xtup chord c else if (multl .ge. multr .and. * .not.btest(islur(ivx,ip+1),29)) then do 1 im = multip , 1+multr, -1 call ntrbbb(im,'t',ulqq,ivb,notexq,lnote) 1 continue c else c Test for next note being blank rest, assuming staff-crossing c xtup chord c else if (.not.btest(islur(ivx,ip+1),29)) then 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 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,tempq character*79 notexq ip1 = ipo(jn) multip = iand(15,mult(ivx,ip1))-8 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 .le. 0) then c if (btest(irest(ivx,ip1),2) .and. c * nodur(ivx,ip1+1).ge.32) then if ((btest(irest(ivx,ip1),2) .and. * nodur(ivx,ip1+1).ge.32) * .or. multip .eq. -1) then c c 1st note of unbeamed half-note trem; make open c notexq = sq//'h'//ulq(ivx,ibmcnt(ivx)) else if (multip .eq. -2) then notexq = sq//'wh' else notexq = sq//'q'//ulq(ivx,ibmcnt(ivx)) end if c c Check for dot c if (btest(irest(ivx,ip1),2) .and. c * abs(nodur(ivx,ip)/12.-nodur(ivx,ip)/12).lt..001) then * abs(nodur(ivx,ip1+1)/12.-nodur(ivx,ip1+1)/12).lt..001) then c c Need a dot. already called addblank for noteq c if (lnote .eq. 0) then notexq = sq//'pt'//noteq(1:lnoten) else notexq = sq//'pt'//noteq(1:lnoten)//notexq(1:lnote) end if lnote = lnote+3+lnoten call notefq(noteq,lnoten,nole,ncmid(iv,ip)) ! Octave changes? if (lnoten .eq. 1) call addblank(noteq,lnoten) end if c c Insert the stemlength calcs here for dotted, unbeamed. c Later may combine with below to avoid repeat. c if (btest(irest(ivx,ip1),2)) then nindent = igetbits(irest(ivx,ip1),2,5) if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then slen = (4.5+nindent+nolev1(ivx)-nole * -.4*islope(ivx)/slfac)*.6667 else slen = (4.5+nindent-nolev1(ivx)+nole * +.4*islope(ivx)/slfac)*.6667 end if write(tempq,'(f4.1)')slen notexq = sq//'slx{'//tempq(1:4)//'}'// * notexq(1:lnote) lnote = lnote+10 end if else if (btest(irest(ivx,ip1),2)) then c c 1st note of unbeamed quarter or 8th trem, make a quarter note c c Stem length calcs here. The .2 factor is empirical, but c slfac accounts for musicsize. c nindent = igetbits(irest(ivx,ip1),2,5) if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then slen = (4.5+nindent+nolev1(ivx)-nole * -.4*islope(ivx)/slfac)*.6667 else slen = (4.5+nindent-nolev1(ivx)+nole * +.4*islope(ivx)/slfac)*.6667 end if write(tempq,'(f4.1)')slen notexq = sq//'slx{'//tempq(1:4)//'}'// * sq//'q'//ulq(ivx,ibmcnt(ivx)) lnote = 13 c c Check for dotted 2-note trem; prepend dot to notexq if needed c if (nodur(ivx,ip1+1).eq.12 .or. * nodur(ivx,ip1+1).eq.24) then if (lnoten .eq. 1) then noteq = ' '//noteq(1:1) lnoten = 2 end if notexq = sq//'pt'//noteq(1:lnoten)//notexq(1:lnote) lnote = lnote+3+lnoten call notefq(noteq,lnoten,nole,ncmid(iv,ip1)) if (lnoten .eq. 1) then noteq = ' '//noteq(1:1) lnoten = 2 end if end if 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 c notexq = notexq(1:3)//'p' c lnote = 4 notexq = notexq(1:lnote)//'p' lnote = lnote+1 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 Check for beamed, dotted 2-note tremolo c if (btest(irest(ivx,ip1),2) .and. * abs(nodur(ivx,ip1+1)/12.-nodur(ivx,ip1+1)/12).lt..001) then call notefq(noteq,lnoten,nole,ncmid(iv,ip)) if (lnoten .eq. 1) then noteq = ' '//noteq(1:1) lnoten = 2 end if if (lnoten .eq. 1) then noteq = ' '//noteq(1:1) lnoten = 2 end if if (lnote .eq. 0) then notexq = sq//'pt'//noteq(1:lnoten) else notexq = notexq(1:lnote)//sq//'pt'//noteq(1:lnoten) end if lnote = lnote+3+lnoten call notefq(noteq,lnoten,nole,ncmid(iv,ip)) if (lnoten .eq. 1) then noteq = ' '//noteq(1:1) lnoten = 2 end if end if c c Put in the note, but check first for open-head beamed tremolo. c if (btest(irest(ivx,ip1),2) .and. nodur(ivx,ip1+1).ge.32) then if (lnote .gt. 0) then notexq = notexq(1:lnote)//sq//'hb' else notexq = sq//'hb' end if else if (lnote .gt. 0) then notexq = notexq(1:lnote)//sq//'qb' else notexq = sq//'qb' end if 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*40 restq 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*1 chax character*8 noteq character*79 notexq,tempq integer nornb(nm),ihornb(nm,24) real*4 space(80),squez(80) logical novshrinktop,cstuplet,usexnumt,writebrests common /comnvst/ novshrinktop,cstuplet common /comfig/ itfig(2,74),figq(2,74),ivupfig(2,74),nfigs(2), * fullsize(nm),ivxfig2,ivvfig(2,74) character*10 figq common /xjbeambrests/ nbrests writebrests = .true. ibc = ibmcnt(ivx) ipb1 = ibm1(ivx,ibc) multb = iand(15,mult(ivx,ipb1))-8 ip = ipo(jn) lnote = 0 nvtrem = 0 ! Vertical adjustment beams for tremolo 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. Also c gets islope(ivx), transferred in common. c if (ixrest(ivx).eq.0 .and. .not.btest(nacc(ivx,ip),21)) * call SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest(ivx)) c c Will always come past here after entering beamstrt for 2-note tremolo, and c slope will have been computed, even for unbeamed. So start the indented c beams here. The indented tremolo bars will be added to the notexq output c string, under the tacet assumption that there is no horizontal shift c enacted by the action just before and after the call to beamstrt. c if (btest(irest(ivx,ipb1),2) .and. * igetbits(irest(ivx,ipb1),2,5) .gt. 0) then nindent = igetbits(irest(ivx,ipb1),2,5) tempq = sq//'roffset{.7}{'//sq//'ib' ltemp = 16 if (nindent .eq. 2) then tempq = tempq(1:16)//'b' ltemp = 17 else if (nindent .eq. 3) then tempq = tempq(1:16)//'bb' ltemp = 18 end if c c Use beam # 0 for indented beams c tempq = tempq(1:ltemp)//ulq(ivx,ibc)//'0' ltemp = ltemp+2 c c Get adjustment to nolev1 for main beam based on nindent c if (ulq(ivx,ibc) .eq. 'u') then nvtrem = nindent-1 else nvtrem = 1-nindent end if c c Get numerical position of initiation for main beam. Will adjust height at c closing to account for nindent c c numinit = nolev1(ivx)-ncmid(ivx,ipb1)+4 numinit = nolev1(ivx)-ncmid(iv,ipb1)+4 c c Get forced beam height tweak, apply here for indented beams c iadj = igetbits(ipl(ivx,ipb1),6,11)-30 if (iadj .ne. -30) numinit = numinit+iadj if (numinit.ge.0 .and. numinit.le.9) then write(noteq,'(i1)') numinit lnoten = 1 else write(noteq,'(a1,i2,a1)')'{',numinit,'}' lnoten = 4 end if tempq = tempq(1:ltemp)//noteq(1:lnoten) ltemp = ltemp+lnoten c c Now do the slope. c 170408 Baseline is in islope(ivx). Apply slope tweak if present. c numinit = islope(ivx) iadj = igetbits(ipl(ivx,ipb1),6,17)-30 if (iadj .ne. -30) numinit = numinit+iadj if (numinit.ge.0 .and. numinit.le.9) then write(noteq,'(i1,a1)') numinit,'}' lnoten = 2 else write(noteq,'(a1,i2,a2)')'{',numinit,'}}' lnoten = 5 end if tempq = tempq(1:ltemp)//noteq(1:lnoten) ltemp = ltemp+lnoten notexq = tempq lnote = ltemp end if 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 c c Move this up to before indented beams for tremolo c 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 c c 130129 If middle note is a rest, go to next note. Note last note cannot c be a rest c 14 continue if (btest(irest(ivx,ipmid),0)) then ipmid = ipmid+1 go to 14 end if 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 Had problem w/ half-note 2-note xtups always F, so add a test c if (igetbits(irest(ivx,ipb1),2,3) .ne. 0) then drawbm(ivx) = .true. go to 6 end if 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 Check for single note xtup 171217 c if (btest(irest(ivx,ipb1),28) .and. nnb.eq.1) then drawbm(ivx) = .false. end if 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)) c Stab in the dark! Note: tried setting unbeam flag islur18 but no go. if (nnb .eq. 1) then xnlmid = nolev1(ivx) islope(ivx) = 0 c c Move up, outside number check block, so all 1-note xtups ar unbeamed c drawbm(ivx) = .false. c end if 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),mult(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 c 130126 Deal with vertical shifts of rest starting xtuplet c lrest = 3 if (btest(islur(ivx,ip),29)) then restq = sq//'sk' c if (multb .eq. 0) then else if (multb .eq. 0) then restq = sq//'qp' else if (.not.drawbm(ivx).and.multb.eq.1) then restq = sq//'ds' else if (.not.drawbm(ivx).and.multb.eq.2) then restq = sq//'qs' else if (.not.drawbm(ivx).and.multb.eq.3) then restq = sq//'hs' else restq = sq//'hpause' lrest = 7 end if if (btest(nacc(ivx,ipb1),18) .and. * btest(nacc(ivx,ipb1),19)) then c c VERY special case of rest at start of F-tuplet, needs dot c restq = sq//'pt4'//restq(1:lrest) lrest = lrest+4 end if nole = mod(nolev(ivx,ip)+20,100)-20 c if (nole .eq. 0) then if (nole.eq.0 .or. btest(islur(ivx,ip),29)) then c c Rest blank or is not raised c notexq = notexq(1:lnote)//restq lnote = lnote+lrest else if (abs(nole) .lt. 10) then tempq = chax(48+abs(nole)) ltemp = 1 else write(tempq(1:2),'(i2)')abs(nole) ltemp = 2 end if if (nole .gt. 0) then tempq = sq//'raise'//tempq(1:ltemp)//sq//'internote' else tempq = sq//'lower'//tempq(1:ltemp)//sq//'internote' end if ltemp = 16+ltemp notexq = notexq(1:lnote)//tempq(1:ltemp)//restq(1:lrest) lnote = lnote+ltemp+lrest 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 But first check if blank rest and if in forced beam (assuming xtuplet), c and if so, count rest from beginning, add \sk's AFTER starting beam '\ib*' c if (btest(islur(ivx,ip),29) .and. btest(ipl(ivx,ip),30)) then nbrests = nbrests+1 writebrests = .false. else 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 end if 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 multbb = multb+iadj c c Tremolo starting? c if (btest(irest(ivx,ipb1),2)) multbb = * igetbits(irest(ivx,ipb1),2,3) call ntrbbb(multbb,'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) c c Add adjustment nvtrem to main beam to account for tremolo indented beams c call notefq(noteq,lnoten,nolev1(ivx)+nvtrem,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 Add in \sk's for very special case of staff-crossing xtup chords c Assumes we are in lower (first) voice of up-to-both beamed xtup c that starts with blank rests (notes in upper voice here). c if (nbrests.gt.0 .and. writebrests) then do 7 isk = 1 , nbrests notexq = notexq(1:lnote)//chax(92)//'sk' lnote = lnote+3 7 continue nbrests = 0 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/ data iTransAmt /nm*0/ end subroutine catspace(space,squez,nnsk) parameter (nkb=3999,maxblks=9600) common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, c * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) * ibaroff,udsp(nkb),wheadpt,sqzb(maxblks) common /comtol/ tol c 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 istart = iccount+2 ! 1 past 1st quote 3 continue iend = index(lineq(istart:128),'"') if (lineq(istart+iend-2:istart+iend-2) .eq. '\') then istart = iccount+iend+2 go to 3 end if 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 c iccount = iccount+iend+2 iccount = istart+iend 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 chkkbdrests(ip,iv,ivx,nn,islur,irest,nolev,ivmx, c * nib,nv,ibar,tnow,tol,nodur,mode,levtopr,levbotr,mult) * nib,nv,ibar,tnow,tol,nodur,mode,levtopr,levbotr,mult,ipl) parameter (nm=24) integer*4 nn(nm),islur(nm,200),irest(nm,200), * nolev(nm,200),nib(nm,15),nodur(nm,200),levbotr(8),levtopr(8), * ivmx(nm,2),mult(nm,200),ipl(nm,200) c c On 130127 put this code, formerly in make2bar right before calling notex for c a single note/rest, into this subroutine, so the same logic could also be c with the calls to beamstrt/mid/end to adjust height of rests in xtups if the c keyboard rest option is selected c c mode=1 if called as before, 2 if for an xtup. Only affects check for c quarter rests, which will fix later. c c Get reference level: next following note if no intervening blank rests, c otherwise next prior note. Relative to bottom line. c c if (ip.ne.nn(ivx).and..not.btest(iornq(ivx,ip),30)) then if (ip.ne.nn(ivx).and..not.btest(ipl(ivx,ip),1)) 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 c if (ip .eq. 1) go to 2 ! Get out if this is the first note. if (ip .eq. 1) return ! 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 c go to 2 ! Pretty odd, should never be here, but get out if so. return ! 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 c go to 2 return end if levother = -iupdown*50 end if 7 continue if (mode.eq.1) then indxr = log2(nodur(ivx,ip))+1 else c nodu = 2**(4-(iand(mult(ivx,ip),15)-8)) indxr = 4-(iand(mult(ivx,ip),15)-8)+1 end if 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 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 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,irest) parameter (nm=24,mv=24576) integer*4 irest(nm,24) 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,iinsiv 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) common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans logical EarlyTransOn,LaterInstTrans common /commidisig/ midisig common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm) common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10), * maxdotmv(nm),ndotmv(nm),updot(nm,20),rtdot(nm,20) 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) .and. nolev.eq.nolevm-1) then c c Upstem, 2nd with upper as main, interchange pitches, c rt-shift upper (now chord note). Lower (orig chord, now main) c if dotted, probably had shifted dot, dot parameters must be moved c from chord to main c nolev = nolevm if (btest(icrdat(icrd),26)) then c c Orig. chord note dot shift, must transfer to main. c icrdotsav = icrdot(icrd) icrdatsav = icrdat(icrd) if (btest(irest(ivx,ip),19)) then c c Main note (upper) had a dot shift, must move it to chord c call setbits(icrdat(icrd),1,26,1) call setbits(icrdot(icrd),7,0, * nint(updot(ivx,ndotmv(ivx)+1)*10)+64) call setbits(icrdot(icrd),7,7, * nint(rtdot(ivx,ndotmv(ivx)+1)*10)+64) c c May need to worry about other chord params (accid shefts etc) later c else icrdat(icrd) = ibclr(icrdat(icrd),26) end if c c We are adding a main note dot shift, so push any later ones back c if (.not.btest(irest(ivx,ip),19)) then maxdotmv(ivx) = maxdotmv(ivx)+1 do 1 indm = maxdotmv(ivx) , ndotmv(ivx)+2 , -1 updot(ivx,indm) = updot(ivx,indm-1) rtdot(ivx,indm) = rtdot(ivx,indm-1) 1 continue end if irest(ivx,ip) = ibset(irest(ivx,ip),19) updot(ivx,ndotmv(ivx)+1) = 0.1*(iand(127,icrdotsav)-64) rtdot(ivx,ndotmv(ivx)+1) = * 0.1*(iand(127,ishft(icrdotsav,-7))-64) end if else if (btest(nacc,31) .and. nolev.eq.nolevm+1) then c c Downstem, 2nd with lower as main, interchange pitches, c left-shift lower (now chord note). Lower (orig main, now chord) c probably had shifted dot, dot parameters must be moved from c main to chord c nolev = nolevm if (btest(irest(ivx,ip),19)) then icrdotsav = icrdot(icrd) icrdatsav = icrdat(icrd) icrdat(icrd) = ibset(icrdat(icrd),26) 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 Assuming >0 for now! call setbits(icrdot(icrd),7,0, * nint(updot(ivx,ndotmv(ivx)+1)*10)+64) call setbits(icrdot(icrd),7,7, * nint(rtdot(ivx,ndotmv(ivx)+1)*10)+64) c c Must also set dot shift for (now) main note (orig. chord note). c if (btest(icrdatsav,26)) then updot(ivx,ndotmv(ivx)+1) = 0.1*(iand(127,icrdotsav)-64) rtdot(ivx,ndotmv(ivx)+1) = * 0.1*(iand(127,ishft(icrdotsav,-7))-64) else c c No dot move on original chord (now main) note, c updot(ivx,ndotmv(ivx)+1) = 0. rtdot(ivx,ndotmv(ivx)+1) = 0. end if end if 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. Basic call for chord notes, not main note. 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.) 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 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 call addmidi(midchan(iv,kv),nolevo+miditran(instno(iv)), * igetbits(icrdat(icrd),3,20),midisig,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) common /comhair/ ihairuse,idhair(nm) 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 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 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 c c 171230 Desperation c lbot = ihornb(ivx,nornb(ivx))+1 if (nornb(ivx).eq.0) then lbot = 1 else lbot = ihornb(ivx,nornb(ivx))+1 end if 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 font-based 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 c c Put in voice number as ID for font-based hairpin 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 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 if (idno .le. 14) then c c Get and record ID no for start of ps hairpin c Find first unused ID c do 8 idh = 1 , 24 if (.not.btest(ihairuse,idh)) go to 9 8 continue call printl('Bad place in putdyn, call Dr. Don') call stop1() 9 continue ihairuse = ibset(ihairuse,idh) idhair(ivx) = idh else c c Unrecord ID no for end of ps hairpin c call setbits(ihairuse,1,idhair(ivx),0) end if c c Write ID # for start or end of ps hairpin c idh = idhair(ivx) if (idh .le. 9) then notexq = notexq(1:lnote)//char(48+idh) lnote = lnote+1 else if (idh .le. 19) then notexq = notexq(1:lnote)//'{1'//char(38+idh)//'}' lnote = lnote+4 else notexq = notexq(1:lnote)//'{2'//char(28+idh)//'}' 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 c if (musize .eq. 20) then c notexq = notexq(1:lnote)//'{'//char(92)//'medtype' c * //char(92)//'it ' c lnote = lnote+13 c else if (musize .eq. 16) then c notexq = notexq(1:lnote)//'{'//char(92)//'normtype' c * //char(92)//'it ' c lnote = lnote+14 c else if (musize .eq. 24) then c notexq = notexq(1:lnote)//'{'//char(92)//'bigtype' c * //char(92)//'it ' c lnote = lnote+13 c else if (musize .eq. 29) then c notexq = notexq(1:lnote)//'{'//char(92)//'Bigtype' c * //char(92)//'it ' c lnote = lnote+13 c end if c c Do this to insert 1st 2 args of \txtdyn, allow 3rd to be longer (on next line) c call addstr(notexq(1:lnote),lnote,soutq,lsout) if (musize .eq. 20) then notexq = '{'//char(92)//'medtype'//char(92)//'it ' lnote = 13 else if (musize .eq. 16) then notexq = '{'//char(92)//'normtype'//char(92)//'it ' lnote = 14 else if (musize .eq. 24) then notexq = '{'//char(92)//'bigtype'//char(92)//'it ' lnote = 13 else if (musize .eq. 29) then notexq = '{'//char(92)//'Bigtype'//char(92)//'it ' lnote = 13 end if c 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 (idh .le. 9) then tempq = 'cresc'//char(48+idh)//'{ }' ltemp = 11 else if (idh .le. 19) then tempq = 'cresc'//'{1'//char(38+idh)//'}{ }' ltemp = 14 else tempq = 'cresc'//'{2'//char(28+idh)//'}{ }' 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,instno) 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,ivvfig(2,74) 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) c wheadpt1 = wheadpt*fullsize(ivx) wheadpt1 = wheadpt*fullsize(instno) 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 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 ndxslur = igetbits(ipl,5,23) call notefq(noteq,lnoten,nolevg(ngs),ncm) call addstr(sq//'tslur',6,soutq,lsout) c 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 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 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. 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,iinsiv 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 /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans logical EarlyTransOn,LaterInstTrans c 130316 common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm) 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 2 stem slur flag c 1 flag for "x" slur (voice-independent) 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. c * kv .eq. igetbits(isdata,1,12)+1) then * (kv .eq. igetbits(isdata,1,12)+1 .or. * btest(isdata,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 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 if (btest(isdata,2)) then c c ADjust for stem slur. ASSUME this is the ONLY pos'n adjustment. c if (stemup) then slurudq = 'u' ivoff = ivoff+4 else slurudq = 'd' ivoff = ivoff-4 end if 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 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.) 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 c Print 23-ndxslur c if (23-ndxslur .lt. 10) then c c 5/25/08 Allow 24 slurs c 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 c c Add note name to string c 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)) = nolevs c 130316 c levson(midchan(iv,kv)) = nolevs-iTransAmt(instno(iv)) levson(midchan(iv,kv)) = nolevs+miditran(instno(iv)) 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. c * kv.eq.igetbits(isdat1(j),1,12)+1) then * (kv.eq.igetbits(isdat1(j),1,12)+1 * .or. btest(isdat1(j),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 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 if (btest(isdata,2)) then c c ADjust for stem slur. c if (stemup) then slurudq = 'u' ivoff = ivoff+4 else slurudq = 'd' ivoff = ivoff-4 end if 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 c if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then c 130316 c if (nolevs-iTransAmt(instno(iv)).eq.levson(icm) .and. if (nolevs+miditran(instno(iv)).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 c levsoff(icm) = nolevs c 130316 c levsoff(icm) = nolevs-iTransAmt(instno(iv)) levsoff(icm) = nolevs+miditran(instno(iv)) 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,iinsiv 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 /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans logical EarlyTransOn,LaterInstTrans c 130316 common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm) 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(1:8) = 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 c levson(midchan(iv,kv)) = nolevs c 130316 c levson(midchan(iv,kv)) = nolevs-iTransAmt(instno(iv)) levson(midchan(iv,kv)) = nolevs+miditran(instno(iv)) 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= 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=9600) 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 c logical gotclef common /c1omnotes/ nnodur,wminnh(nkb),nnpd(maxblks),durb(maxblks), * iddot,nptr(nkb),ibarcnt,mbrest,ibarmbr, c * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) * ibaroff,udsp(nkb),wheadpt,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') print*,'ivx,ip:',ivx,ip 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=9600) 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, c * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) * ibaroff,udsp(nkb),wheadpt,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*131072 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),lyrerq(5) 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) common /commidisig/ midisig common /comis4bignv/ is4bignv,AIset logical is4bignv,AIset 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!'/ data lyrerq * /'pmxlyr string must end with " followed by blank!', * 'pmxlyr string cannot extend past position 120!', * 'There must be "a" or "b" here!', * 'There must be "+" or "-" here!', * 'There must be an integer here!'/ 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 /' print*,'appending /' 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 c 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) if (lineq(iccount-1:iccount-1).eq.'.') iccount=iccount-1 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 (index('LS',durq) .gt. 0) 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 stemlegth changes without turning on!') call stop1() end if stickyS = .false. go to 2 end if call readnum(lineq,iccount,durq,dum) c if (dum.lt..5 .or. dum.gt.4.) then if ((durq.eq.'L'.and.dum.gt.20.).or. * (durq.eq.'S'.and.dum.gt.4.)) then call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1, * 'Stemlength change amount too big!') 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('123456789T',durq) .eq. 0) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * 'First char after "x" in xtuplet must be "1"-"9" or "T"!') call stop1() end if if (durq .eq. 'T') then c c Check all x-tremolo inputs here; set fnum=2 c fnum = 2 call getchar(lineq,iccount,durq) if (index('0123 ',durq).eq.0) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * 'First char after "T" in xtuplet must be "0"-"3" or blank!') call stop1() else if (durq .ne. ' ') then call getchar(lineq,iccount,durq) if (index('0123 ',durq).eq.0) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * 'This char must be "0"-"3" or blank!') call stop1() else if (durq .ne. ' ') then call getchar(lineq,iccount,durq) c c Probably blank unles other options entered c end if end if else c c durq is digit, normal xtup c call readnum(lineq,iccount,durq,fnum) c c Leaves durq at next char after number c 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 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 c if ((numshft.eq.1 .and. snum.gt.15.1) .or. if ((numshft.eq.1 .and. snum.gt.64.) .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('udlbfnhtv',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 if (lineq(iccount+1:iccount+1).eq.'x') * iccount = iccount+1 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) c if (index('0123456789#-n_.:',durq) .gt. 0) then if (index('0123456789#-n_.:v',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. '"') then c c pmx lyric c call chkpmxlyr(lineq,iccount,lyrerr) if (lyrerr .gt. 0) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * lyrerq(lyrerr)) 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,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 c 140215 Allow clef change inside xtup c else if (durq .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.55))) then * (ichar(durq).ge.48 .and. ichar(durq).le.56))) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * 'Must have t,s,m,a,n,r,b,f or 0-8 after C!') call stop1() end if c gotclef = .true. 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() end if 7 call g1etchar(lineq,iccount,durq) c if (index('2345678ulcb',durq) .gt. 0) then if (index('12345678ulcb',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 .eq. 'T') then c c Single stem tremolo. Only option (optional) is 1,2,3, or 4. c call getchar(lineq,iccount,durq) if (index('1234',durq) .eq. 0) iccount = iccount-1 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. '"') then c c pmx lyric c call chkpmxlyr(lineq,iccount,lyrerr) if (lyrerr .gt. 0) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * lyrerq(lyrerr)) 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) c if (index('(stmgx+Tupf._)e:>^bc',dumq) .eq. 0 ) then if (index('(stmgx+Tupf._)e:>^bcCG',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+-fnhHpsv ',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() else if (lineq(iccount+1:iccount+1).eq.'x') then iccount = iccount+1 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_.:+sv',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 c c 151211 fix. May have extra character. c if (index('pim',durq) .gt. 0) then c c Get another character, see if it's blank c if (lineq(iccount+1:iccount+1) .ne. ' ') then call errmsg(lineq,iccount+1,ibarcnt-ibaroff+nbars+1, * 'This character should be a blank!') call stop1() end if 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 c * (ichar(durq).ge.48 .and. ichar(durq).le.55))) then * (ichar(durq).ge.48 .and. ichar(durq).le.56))) 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 0-8 after C!') call stop1() end if c 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 c10 call g1etchar(lineq,iccount,durq) c if (index('lrdDbz',durq) .gt. 0) go to 10 c if (durq .ne. ' ') then c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, c * 'Illegal character after "R" (repeat/double bar)!') c call stop1() c end if call g1etchar(lineq,iccount,durq) call g1etchar(lineq,iccount,dumq) if (index('l Xr Xd XD Xb Xz XlrXdlX',durq//dumq) .eq. 0) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * 'Illegal character after "R*" (repeat/double bar)!') call stop1() end if if (dumq .ne. ' ') then call g1etchar(lineq,iccount,durq) if (durq .ne. ' ') then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * 'Must have blank after "R**" (repeat/double bar)!') call stop1() end if 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.'"' .and. * lineq(iccount-1:iccount-1).ne.'\') 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) c if (index('rbsdeK',durq) .gt. 0) then if (index('rbsdK',durq) .gt. 0) then go to 27 else if (durq .eq. 'e') then c c Check for is4bignv. Must do here to catch first \internote, written in topfile c before ever calling getnote. Initialize as .false. in pmxa. Make it true only c if nv>7, AI not set, Ai not set. c is4bignv = nv.gt.7 .and. .not.AIset 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) if (index('0123456789.',durq) .eq. 0) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * 'After "Aa", need decimal number!') call stop1() end if call readnum(lineq,iccount,durq,fbar) iccount = iccount-1 go to 27 else if (durq .eq. 'i') then is4bignv = .false. AIset = .true. 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 is4bignv = .false. AIset = .true. 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 c 130324 c do 50 iiv = 1 , nv do 50 iiv = 1 , noinst 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 .eq. 'V') then call g1etchar(lineq,iccount,durq) if (index('+-',durq) .eq. 0) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * 'Only "+" or "-" is allowed here!') call stop1() end if call g1etchar(lineq,iccount,durq) if (index('0123456789.',durq) .eq. 0) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * 'A number for vert shift before \eject must start here!') call stop1() end if call readnum(lineq,iccount,durq,fnum) if (index('+-',durq) .eq. 0) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * 'Only "+" or "-" is allowed here!') call stop1() end if call g1etchar(lineq,iccount,durq) if (index('0123456789.',durq) .eq. 0) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * 'A number for vert shift after \eject must start here!') call stop1() end if call readnum(lineq,iccount,durq,fnum) iccount = iccount-1 go to 27 else if (durq .ne. ' ') then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, c * 'After "A" must follow one of the letters abcdeiINprRsST!') * 'After "A" must follow one of abcdeiILNprRsSTvV!') print*,'For AS, since ver. 2.7, must only have noinst args.' write(15,'(a)') * 'For AS, since ver. 2.7, must only have noinst args.' 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 77 continue call g1etchar(lineq,iccount,durq) c if (index('+-i',durq) .eq. 0) then if (index('+-in',durq) .eq. 0) then call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, * '"K" (transpose or key change) must be followed by "+,-,i,n"!') call stop1() end if if (durq .eq. 'n') go to 77 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 c 130316 c do 43 iinst = 1 , noinst midisig = newkey(nkeys) c43 continue 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) 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() c c 140215 Temporary to allow clef change in stup c c else if (gotclef) then c call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1, c * 'May not enter clef at end of input block!') c 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, timesofar are ',lenbar,itsofar(ivx) 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,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. c call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, call getmidi(noinst,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=9600) character*131072 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 common /commidisig/ midisig 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)) c 130316 c do 11 iinst = 1 , noinst midisig = newkey c11 continue 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('brnamstf01234567',lineq(iv:iv)) .eq. 0) then if (index('brnamstf012345678',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 c bottreb = lineq(1:1).eq.'t' bottreb = index('t08',lineq(1:1)).gt.0 c c Next 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,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 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() 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=9600) character*(*) lineq character*131072 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 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 iccountt = iccount 3 continue iend = iccountt+index(lineq(iccountt+2:128),'"')+2 if (lineq(iend-2:iend-2) .eq. '\') then iccountt = iend-2 go to 3 end if txtdynq(ntxtdyn) = lineq(iccount+2:iend-2) c c Store ivx, ip in bits 0-12 c 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, c * itsofar,nodur,figq,ivupfig,nfigs) * itsofar,nodur,figq,ivupfig,ivvfig,nfigs) logical isfig character*1 charq character*10 figq character*128 lineq nfigs = nfigs+1 ivupfig = 0 ivvfig = 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 (index(' +',charq) .eq. 0) then if (index(' +v',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) else if (charq .eq. 'v') then c c Get vertical change in figdrop. Must be last item in figure word. c isign = 1 call getchar(lineq,iccount,charq) if (charq .eq. '-') then isign=-1 call getchar(lineq,iccount,charq) end if ivvfig = isign*(ichar(charq)-48) 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) 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(noinst,lineq,iccount,ibarcnt,ibaroff,nbars, * lenbar, c 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),noinstdum,iinsiv(nm) integer*2 iinsiv 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 cc Instrument numbers or letters. Expect nv of them. c Instrument numbers or letters. Expect noinst of them. c c do 2 ivx = 1 , nv do 2 ivx = 1 , noinst 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 c do 7 ivx = 1 , nv do 7 ivx = 1 , noinst 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 c do 8 ivx = 1 , nv do 8 ivx = 1 , noinst 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 c do 9 ivx = 1 , nv do 9 ivx = 1 , noinst 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!') write(*,'(a)') * 'May be too many args to i,v,b, or T. As of Ver. 2.7, '// * 'should be noinst, not nv' write(15,'(a)') * 'May be too many args to i,v,b, or T. As of Ver. 2.7, '// * 'should be noinst, not nv' 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,ignorenats common /comignorenats/ ignorenats 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,ivvfig(2,74) common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd, * npreslur,was2(nm),ninow,nobar1,nsystp(75),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), * maxdotmv(nm),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,lineqt 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 common /commidisig/ midisig common /comlyr/ inputmlyr logical inputmlyr common /combottop/ botamt,topamt,bottopgap logical bottopgap logical inxtup cdot = .false. inxtup = .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) c call setbits (mult(ivx,nnl(ivx)),3,28, c * igetbits(mult(ivx,nnl(ivx)-1),3,28)) call setbits (mult(ivx,nnl(ivx)),6,10, * igetbits(mult(ivx,nnl(ivx)-1),6,10)) 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 c if (nacc(ivx,nnl(ivx)) .eq. 0) then c 171209 May have set bit 18 earlier if D or F preceded accidental if (igetbits(nacc(ivx,nnl(ivx)),2,0) .eq. 0) then c c No accidental has been set yet c c nacc(ivx,nnl(ivx)) = index('fsn',durq) nacc(ivx,nnl(ivx)) = * ior(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-1 c 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 Initialize counter for # of non-rests, so can later unbeam if = 1. c inxtup = .true. note1xtup = nnl(ivx) nnb = 0 if (.not.btest(irest(ivx,nnl(ivx)),0)) nnb = 1 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 unless its a "T" c iccount = iccount+1 if (lineq(iccount:iccount) .eq. 'T') then c c Set up tremolo c irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),2) ntup = 2 c c Set default beaming, based on Wikipedia article c May be a problem here is nnodur is inherited c if (nnodur .eq. 4) then nsolid = 0 nindent = 3 else if (nnodur .eq. 2) then nsolid = 3 nindent = 0 else if (nnodur .eq. 8) then nsolid = 1 nindent = 2 end if call getchar(lineq,iccount,durq) if (index('0123456789',durq) .gt. 0) then nsolid = index('0123456789',durq)-1 if (nsolid.eq.0 .and. nnodur.eq.2) then print*,'' print*,'Unbeamed half-note 2-note tremolo forbidden.' call stop1() end if call getchar(lineq,iccount,durq) if (index('0123456789',durq) .gt. 0) then nindent = index('0123456789',durq)-1 end if end if call setbits(irest(ivx,nnl(ivx)),2,3,nsolid) call setbits(irest(ivx,nnl(ivx)),2,5,nindent) if (nsolid .eq. 0) then islur(ivx,nnl(ivx)) = * ibset(islur(ivx,nnl(ivx)),18) end if islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),31) islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),21) call setbits(islur(ivx,nnl(ivx)+1),3,22,nsolid) c c Set some force-beam parameters for the tremolo c c Need to check if there's already a forced beam explicitly set here. c If there was, shouldn't do any harm resetting parameters. c if (nfb(ivx).eq.0 .or. t1fb(ivx,nfb(ivx)).ne.itsofar(ivx)) * nfb(ivx) = nfb(ivx)+1 fbon = .true. ulfbq(ivx,nfb(ivx)) = 'x' t1fb(ivx,nfb(ivx)) = itsofar(ivx) t2fb(ivx,nfb(ivx)) = itsofar(ivx) + ifnodur(nnodur,dotq) nadj = 0 c c Set open beamed notehead flag for half-note tremolo c Just gave 2 quarters with or without flag set. Need to fix c else call readnum(lineq,iccount,durq,fnum) ntup = nint(fnum) end if if (index('DF',durq) .gt. 0) then c 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 160214 Allow (-64,64) c iofforn = iofforn*nint(xofforn) + 16 iofforn = iofforn*nint(xofforn) + 64 c cc Turn on bit 1; set bits 2-6 to iofforn c Turn on bit 1 of irest; set bits 16-22 of mult to iofforn c c irest(ivx,nnl(ivx)) = c * ior(irest(ivx,nnl(ivx)),2+4*iofforn) irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),1) call setbits(mult(ivx,nnl(ivx)),8,16,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 (charq .eq. '"') then c c pmxlyr string in xtup. Expand "..." to \pmxlyr{...}\ c if (.not. inputmlyr) then ictemp = 0 lineqt = sq//sq//sq//'input musixlyr '//sq call littex(islur,nnl(ivx)+1,ivx,topmods,lineqt,ictemp) inputmlyr = .true. end if call dopmxlyr(lineq,iccount) charq = sq 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), c * 0,figq(ivf,nfig1),ivupfig(ivf,nfig1),nfigs(ivf)) * 0,figq(ivf,nfig1),ivupfig(ivf,nfig1),ivvfig(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 c 140215 Allow clef change inside xtuplet. With normal code, came out one c note too late, so try making it come earlier. c 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 c if (nnl(iv) .gt. 0) ncc(iv) = ncc(iv)+1 if (nnl(iv)-1 .gt. 0) ncc(iv) = ncc(iv)+1 c c 140218 Need to get time differently inside xtup, since itsofar doesn't get c updated until after xtup is done c nodurt = ifnodur(nnodur,dotq) tcc(iv,ncc(iv)) = itsofar(iv)+int(1.*nodurt/ntup*(itup-1)) isl = ibset(islur(iv,nnl(iv)),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) if (durq .eq. '8') then ipl(iv,nnl(iv))=ibset(ipl(iv,nnl(iv)),2) iTransAmt(instno(iv)) = 7+iTransAmt(instno(iv)) end if 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 70 iiv = 1 , iv c nnliiv = nnl(iiv) nnliiv = nnl(iiv)-1 if (iiv .eq. iv) nnliiv = nnliiv+1 itother = 0 do 71 iip = 1 , nnliiv if (itother .lt. itsofar(iv)) then itother = itother+nodur(iiv,iip) go to 71 else if (itother .eq. itsofar(iv)) then islur(iiv,iip) = ibset(islur(iiv,iip),15) go to 72 end if 71 continue 70 continue 72 continue end if c c Need 'or' since may have set bit 15 in the above loop c c islur(iv,nnl(iv)+1) = ior(isl,islur(iv,nnl(iv)+1)) islur(iv,nnl(iv)) = ior(isl,islur(iv,nnl(iv))) 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 c end if else c c Counter for non-rests c nnb = nnb+1 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 c c if (nacc(ivx,nnl(ivx)) .eq. 0) then c May have set other bits earlier if (igetbits(nacc(ivx,nnl(ivx)),2,0) .eq. 0) then c c No accid set yet c c nacc(ivx,nnl(ivx)) = index('fsn',durq) nacc(ivx,nnl(ivx)) = * ior(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 (index('LS',durq) .gt. 0) then c c Stemlength change. Get dstemlen in \internotes. Allowable values are -4 to 27.5 c Set mult(27). Map value to 0 to 63, store in mult(10-15). Later convert to c interbeams = internotes*2/3. c c isign = 1 if (durq .eq. 'S') isign = -1 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)),6,10, * igetbits(mult(ivx,nnl(ivx)-1),6,10)) 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) dum = isign*dum call setbits (mult(ivx,nnl(ivx)),6,10,nint((dum+4.)*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 c iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),30) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),1) 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 .eq. 'T') then call getchar(lineq,iccount,durq) multtrem = index('1234',durq) if (multtrem .eq. 0) then iccount = iccount-1 multtrem = 1 end if ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),4) call setbits(ipl(ivx,nnl(ivx)),2,5,multtrem-1) 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 c c Only matters if last note, non-rest of xtuplet c nnb = nnb+1 end if c c Set flag for unbeamed xtup if it just has 1 note c if (inxtup .and. nnb.eq.1) then c ??? islur(ivx,note1xtup) = ibset(islur(ivx,note1xtup),19) islur(ivx,note1xtup) = ibset(islur(ivx,note1xtup),18) 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) 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 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. '"') then c c pmxlyr string. Expand "..." to \pmxlyr{...}\ c if (.not. inputmlyr) then ictemp = 0 lineqt = sq//sq//sq//'input musixlyr '//sq call littex(islur,nnl(ivx)+1,ivx,topmods,lineqt,ictemp) inputmlyr = .true. end if call dopmxlyr(lineq,iccount) charq = sq 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), c * ivupfig(ivf,nfig1),nfigs(ivf)) * ivupfig(ivf,nfig1),ivvfig(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)//'%' if (fullsize(iiorig(iinow)).gt.0.9) then write(11,'(a)')sq//'setsize'//chax(48+iinow) * //sq//'normalvalue%' c c 140526 Account for staff size specs when noinst changes. May be confusion c here if more than one staff per instrument c else if (fullsize(iiorig(iinow)).gt..7) then write(11,'(a)')sq//'setsize'//chax(48+iinow) * //sq//'smallvalue%' else write(11,'(a)')sq//'setsize'//chax(48+iinow) * //sq//'tinyvalue%' end if 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) if (durq .eq. '8') then ipl(iv,nnl(iv)+1)=ibset(ipl(iv,nnl(iv)+1),2) iTransAmt(instno(iv)) = 7+iTransAmt(instno(iv)) lastlev = lastlev+7 else c c This won't work if you really had an octave transposition with some c other clef. Need a check on whether prior clef was an octave clef. c if (iTransAmt(instno(iv)).eq.7) then iTransAmt(instno(iv))=iTransAmt(instno(iv))-7 lastlev = lastlev-7 print*,'Reset itransamt to ',iTransAmt(instno(iv)) end if end if 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 c iornq(1,nnl(1)+1) = ibset(iornq(1,nnl(1)+1),29) ipl(1,nnl(1)+1) = ibset(ipl(1,nnl(1)+1),0) 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 c if ((quoted .and. lineq(iccount:iccount) .eq. '"') .or. if ((quoted .and. lineq(iccount:iccount).eq.'"' .and. * lineq(iccount-1:iccount-1).ne.'\') .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(1:60) 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 c 130324 c do 50 iiv = 1 , nv do 50 iiv = 1 , noinst 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 c fullsize(ivx) = 1.0 fullsize(iiv) = 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 pmxa c go to 27 else if (durq .eq. 'V') then bottopgap = .true. topamt = 0. call getchar(lineq,iccount,durq) pmfac = index('- +',durq)-2 call g1etchar(lineq,iccount,durq) call readnum(lineq,iccount,durq,botamt) botamt = botamt*pmfac pmfac = index('- +',durq)-2 call g1etchar(lineq,iccount,durq) call readnum(lineq,iccount,durq,topamt) topamt = topamt*pmfac iccount = iccount-1 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 77 continue call getchar(lineq,iccount,durq) if (durq .eq. 'n') then ignorenats = .true. go to 77 end if 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 (ismidi) then midisig = nint(fnum) if (durq.eq.'-') midisig = -midisig c 130317 midisig = midisig+idsig call midievent('k',midisig,0) end if c70 continue 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. c call GetiTransInfo(.false.,ibarcnt,lineq,iccount, * ibaroff,nbars,noinst) c c The sig parameters will have been set 1st time but that's OK c 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 c call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar, call getmidi(noinst,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 ? for ed. accid. 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 c iorni = iand(4194303,iornq) c iorni = iand(541065215,iornq) iorni = iand(1614807039,iornq) else iorni = iand(4194303,icrdorn(ncrd)) end if c korn = index('stmgx+Tupf._)e:XXX>^',charq) korn = index('stmgx+Tupf._)e:XXX>^XXXXXXXXCG',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 cc Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21 prev iornq c Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21,29 prev iornq c c iorni = ior(iorni,iand(iornq0,1638383)) c iorni = ior(iorni,iand(iornq0,3735535)) c iorni = ior(iorni,iand(iornq0,540606447)) iorni = ior(iorni,iand(iornq0,1614348271)) 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) c 141226 ornhshft(nudorn) = nint(xofforn*fnum) ornhshft(nudorn) = 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=9600,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*131072 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 common /commidisig/ midisig 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)) c 130316 c do 11 iinst = 1 , noinst c midisig(iinst) = isig0 midisig = isig0 c11 continue 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 Next 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 c c 160130 Replace '\' by '/' c 12 ipos = index(pathnameq,'\') if (ipos .gt. 0) then pathnameq(ipos:ipos)='/' print*,'Changed pathname to ',pathnameq(1:lpath) go to 12 end if 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 c c Type 2 or 3. c 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 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 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 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=9600) 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*131072 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,ivvfig(2,74) 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), * maxdotmv(nm),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 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,ivvfig(2,74) 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), * maxdotmv(nm),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,udq 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 common /comignorenats/ ignorenats logical ignorenats integer*2 mmidi,iinsiv 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 common /comInstTrans/ iInstTrans(nm),iTransKey(nm),iTransAmt(nm), * instno(nm),nInstTrans,EarlyTransOn,LaterInstTrans logical EarlyTransOn,LaterInstTrans common /commidisig/ midisig c 130316 common /commvel/ midivel(nm),midvelc(0:nm),midibal(nm),midbc(0:nm) * ,miditran(nm),midtc(0:nm),noinst,iinsiv(nm) common /comclefrests/ centrests logical centrests common /xjbeambrests/ nbrests nbrests = 0 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, * iand(ishft(islur(ivxo(in),ipo(in)),-12),7)) c c If clefq = '8', must add eg \settrebleclefsymbol3\treblelowoct% c c if (clefq(ivxo(in)) .eq. '8') then if (btest(ipl(ivxo(in),ipo(in)),2)) then if (iv .le. 9) then write(11,'(a20,i1,a)')sq//'settrebleclefsymbol',iv, * sq//'treblelowoct%' else write(11,'(a20,i2,a)')sq//'settrebleclefsymbol',iv, * sq//'treblelowoct%' end if end if 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 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 c 130324 c wheadpt1 = wheadpt*fullsize(iv) wheadpt1 = wheadpt*fullsize(instno(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 ! cautionary accidental 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 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 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 <>???? 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 c if (poenom*esk .lt. ptsneed) call addask(to(in),ptsneed, c * esk,fixednew,scaldold,0.,.false.) if (poenom*esk .lt. ptsneed) then call addask(to(in),ptsneed, * esk,fixednew,scaldold,0.,.false.) end if 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,istart,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 .and. ignorenats) * write(11,'(a)')sq//'ignorenats%' 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 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) end if call clefsym(islur(iv,ip),notexq,lnote,nclef) c c 151220 If clef is treblelowoct, change '0' in pos'n 9 to '8' c if (btest(ipl(ivx,ip),2)) notexq = * notexq(1:8)//'8'//notexq(10:10) 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 if (kbdrests .and. btest(irest(ivx,ip),0) .and. * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and. * nolev(ivx,ip).le.50) * call chkkbdrests(ip,iv,ivx,nn,islur,irest,nolev, * ivmx,nib,nv,ibar,tnow,tol,nodur,2,levtopr,levbotr, * mult,ipl) 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), c 130324 c * tnote(ipl2(ivx,ip)),ulq) * tnote(ipl2(ivx,ip)),ulq,instno(iv)) 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) cc else if (iand(mult(ivx,ip),15)-8 .lt. 0) then c else if (iand(mult(ivx,ip),15)-8 .lt. 0 .or. c * (btest(irest(ivx,ip),2).and.nodur(ivx,ip+1).eq.32) .or. c * (ip.gt.1.and.btest(irest(ivx,ip-1),2) c * .and.nodur(ivx,ip).eq.32)) then c nodu = 32 c else c nodu = 16 c end if else if (btest(irest(ivx,ip),2) .or. * (ip.gt.1.and.btest(irest(ivx,ip-1),2))) then c c In a 2-note tremolo c if (btest(irest(ivx,ip),2)) then c c First note of tremolo, duration is on next note c nodu = nodur(ivx,ip+1) else nodu = nodur(ivx,ip) end if 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), * irest) end if c c Now that chords are done, add stuff to midi file c if (ismidi) call addmidi(icm, c 130316 c * nolev(ivx,ip)-iTransAmt(instno(iv)), * nolev(ivx,ip)+miditran(instno(iv)), c * iand(nacc(ivx,ip),7),midisig(instno(iv)), * iand(nacc(ivx,ip),7),midisig, * 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 c isacc = iand(iornq(ivx,ip),4194287) .gt. 0 c isacc = iand(iornq(ivx,ip),541065199) .gt. 0 isacc = iand(iornq(ivx,ip),1614807023) .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 main notes with moved dots. Chord notes done elsewhere. c Added check rules out special chordal 2nds, but later must check c substituted chord note for dot shift that now applies to main note. 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 changes c if (btest(mult(ivx,ip),27)) then dstemlen = igetbits(mult(ivx,ip),6,10)*.5-4. stemshort = 4.66+.667*dstemlen call addstr(sq//'stemlength{',12,soutq,lsout) write(notexq,'(f4.1)')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 if (kbdrests .and. btest(irest(ivx,ip),0) .and. * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and. * nolev(ivx,ip).le.50) * call chkkbdrests(ip,iv,ivx,nn,islur,irest,nolev, * ivmx,nib,nv,ibar,tnow,tol,nodur,2,levtopr,levbotr, * mult,ipl) if (btest(islur(ivx,ip),29) * .and.btest(irest(ivx,ip),24)) then notexq = chax(92)//'sk' lnote = 3 else call beamn1(notexq,lnote) end if 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 c c Added 130127 c if (kbdrests .and. btest(irest(ivx,ip),0) .and. * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and. * nolev(ivx,ip).le.50) * call chkkbdrests(ip,iv,ivx,nn,islur,irest,nolev, * ivmx,nib,nv,ibar,tnow,tol,nodur,2,levtopr,levbotr, * mult,ipl) 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) c if (kbdrests .and. btest(irest(ivx,ip),0) .and. * .not.btest(islur(ivx,ip),29).and. nvmx(iv).eq.2 .and. * nolev(ivx,ip).le.50) then call chkkbdrests(ip,iv,ivx,nn,islur,irest,nolev, * ivmx,nib,nv,ibar,tnow,tol,nodur,1,levtopr,levbotr, * mult,ipl) end if if (btest(ipl(ivx,ip),4)) then c c Deal with single stem tremolo c Get up-downness, borrowed from notex c if (udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip), * nvmx(iv),ivx,nv).eq.'u') then udq = 'u' else udq = 'l' end if multtrem = igetbits(ipl(ivx,ip),2,5)+1 if (nodur(ivx,ip) .lt. 64) then notexq = sq//'tr' else notexq = sq//'Tr' end if lnote = 3 if (multtrem .eq. 2) then notexq = notexq(1:3)//'r' lnote = 4 else if (multtrem .eq.3) then notexq = notexq(1:3)//'rr' lnote = 5 end if c c Get a numerical pitch argument c lineno = nolev(ivx,ip)-ncmid(iv,ip)+4 if (lineno .lt.0 .or. lineno .gt.9) then write(noteq,'(a1,i2,a1)')'{',lineno,'}' lnoten = 4 else noteq = char(lineno+48) lnoten = 1 end if notexq = notexq(1:lnote)//'m'//udq//noteq(1:lnoten) lnote = lnote+2+lnoten call addstr(notexq,lnote,soutq,lsout) end if c c Get code for a separate note or rest c If nacc(ivx,ip)(30-31)=1 (dotted chordal 2nd including main note), c pitch will be shifted +/-1 inside notex. 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) then call addstr(notexq,lnote,soutq,lsout) end if 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., c 130324 c * .false.,0,0,0,0,0,0,0.,ulq) * .false.,0,0,0,0,0,0,0.,ulq,instno(iv)) 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., c 130324 c * .false.,0,0,0,0,0,0,0.,ulq) * .false.,0,0,0,0,0,0,0.,ulq,instno(iv)) 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 if (ibar.eq.ibarmbr .and. islast) then 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 = nint(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. Set flag to pass to pmxb at start of NEXT bar c to check for new clef and add space by redefining \CenterBar c centrests = .true. call addstr(sq//'def'//sq//'value{0}',13,soutq,lsout) call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes',22, * soutq,lsout) do 60 iv = 1 , nv c added lnote = 0 c do 61 kv = 1 , nvmx(iv) ivx = ivmx(iv,kv) if (cwrest(ivx)) then call addstr(sq//'CenterBar{',11,soutq,lsout) 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 call addstr(cwrq(ivx)(1:lcwr(ivx)),lcwr(ivx),soutq, * lsout) call addstr('}{-2}{'//sq//'value}',13,soutq,lsout) 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 notexq = notexq(1:lnote)//sq//'loffset{.33}{' * //sq//'fermataup7}'//cwrq(ivx)(1:lcwr(ivx)) * //'}{-2}{'//sq//'value}' lnote = lnote+26+lcwr(ivx)+13 call addstr(notexq,lnote,soutq,lsout) cwrferm(ivx) = .false. end if end if 61 continue if (iv .ne. nv) call addstr(sepsymq(iv),1,soutq,lsout) 60 continue if (islast) then call addstr(sq//'en}%',5,soutq,lsout) if (lsout.gt.0)write(11,'(a)')soutq(1:lsout) end if 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) 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=9600) 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, c * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) * ibaroff,udsp(nkb),wheadpt,sqzb(maxblks) common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar,nacc(nm,200) c logical rest,firstline,newmeter,gotclef logical rest,firstline,newmeter 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=9600) 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*131072 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), * maxdotmv(nm),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 if (clefq .eq. '8') then c c treblelowoct; will treat as treble for this purpose c ncmidf = 35 else ncmidf = 21+index(' b6r5n4a3m2s1t0f7',clefq)/2*2 end if 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), * maxdotmv(nm),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,ivvfig(2,74) 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 c Special case for rest at start of F-tuplet inside a forced beam c if (btest(nacc(ivx,ip),18) .and. * btest(nacc(ivx,ip),19)) then restq = sq//'pt4'//restq(1:lrest) lrest = lrest+4 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 notexq = notexq(1:lnote)//restq(1:lrest) lnote = lnote+lrest 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 c For input 0-6 or tsmanrb return 0-7 c 7 f 9 c 8 0 c character*1 clefq if (ichar(clefq) .lt. 55) then c if (ichar(clefq) .le. 55) then numclef = ichar(clefq)-48 c if (numclef .eq. 7) numclef = 9 else if (clefq .eq. '7') then numclef = 9 else if (clefq .eq. '8') then numclef = 0 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=9600) logical loop,usefig,isfirst,optimize character*131072 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, c * ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(maxblks) * ibaroff,udsp(nkb),wheadpt,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 c logical mrecord,mplay,endmac,gotclef,cstuplet logical mrecord,mplay,endmac,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 common /comis4bignv/ is4bignv,AIset logical is4bignv,AIset data wtimesig,wclef,wkeysig * / 0.72 , 0.8 , 0.28 / is4bignv = .false. AIset = .false. 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. c 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 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 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 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=9600) 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 c 0 blank barline (must be iv=1) (would have used islur but no room) c 1 look left for K rests, moved here from iornq(30) c 2 treblelowoct c 3 Open notehead in forced beam xtup c 4 Set if single stem tremolo c 5-6 termulo multiplicity - 1 c 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. 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 cc 29 blank barline (must be iv=1) (would have used islur but no room) c 29 coda cc 30 "Look-left" option for keyboard rest c 30 Part-by-part segno oG 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 Set if 2-note tremolo starts here c 3-4 nsolid, # of solid beams in 2-note tremolo c 5-6 nindent, # of indented beams in 2-note tremolo 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 10-15 New stem length, [0-63] => (-4,0,+27.5) c 16-22 64+Vertical offset of xtup # c 27 Stemlength override cc 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*131072 bufq integer*2 lbuf(maxblks) common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq character*10 figq common /comignorenats/ ignorenats logical ignorenats 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(75),xintstaff(75),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,ivvfig(2,74) 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(75),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), * maxdotmv(nm),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 common /commidisig/ midisig common /comclefrests/ centrests logical newclef, centrests common /comlyr/ inputmlyr logical inputmlyr /.false./ common /combottop/ botamt,topamt,bottopgap logical bottopgap common /comis4bignv/ is4bignv,AIset logical is4bignv,AIset common /comhair/ idhairuse,idhair(nm) bottopgap = .false. idhairuse = 0 if (.not.optimize) then print* print*,'Starting second PMX pass' print* write(15,'(a)')'Starting second PMX pass' end if newclef = .false. centrests = .false. ncalls = ncalls+1 islast = inlast macuse = 0 isyscnt = 0 stemmax = 8.2 stemmin = 3.9 stemlen = 6.0 sq = chax(92) ignorenats = .false. 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 130313 Unless explicit miditranspose for all parts (to be dealt with later), c want concert sig (isig0) here. K+n+m will have changed sig to isig c call midievent('k',isig,0) c 130316 c call midievent('k',isig0,0) c call midievent('k',midisig,0) c c Above is probably cosmetic c call midievent('k',midisig,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 maxdotmv(iv) = ndotmv(iv) 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 c if (ibar.eq.1 .and. firstgulp .and. c * .not.btest(islur(1,1),5)) xb4mbr = facmtr*musicsize if (ibar.eq.1 .and. firstgulp .and. * .not.btest(islur(1,1),5)) xb4mbr = -.2*musicsize 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 ccc ccc Clef change and multi-bar rest coming up. Kluge to get space at end of rest. ccc 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}%' cc cc RDT suggestion is inset blank barline - 160103 Abandoned cc c write(11,'(a)')sq//'setemptybar'//sq//'bar'//sq//'qspace' c * //sq//'advance'//sq//'barno-1' 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) c c If clefq = '8', must change '0' in pos'n 9 to '8' c if (btest(ipl(iv,ioff+1),2)) fmtq = * fmtq(1:8)//'8'//fmtq(10:10) if (movbrk.eq.0 .and. * islast) * write(11,'(a)')notexq(1:lnote)//fmtq(1:lclef)//sq//'en%' c call wsclef(iv,ninow,clefq,nclef) call wsclef(iv,ninow,nclef) c c Set new flag to be used just outside this loop, to kluge c any calls to \CenterBar for full-bar rests, to make room for clef. c newclef = .true. c c 151220 c wrong test: c If clefq = '8', must add eg \settrebleclefsymbol3\treblelowoct% c Replaced with right one. But also, clefq(iv) seems to stay at 8 here, c and if we change from TLO to normal clef, need to resetclefsymbols c c if (clefq(iv) .eq. '8') then if (btest(ipl(iv,ioff+1),2)) then if (iv .le. 9) then write(11,'(a20,i1,a)')sq//'settrebleclefsymbol',iv, * sq//'treblelowoct%' else write(11,'(a20,i2,a)')sq//'settrebleclefsymbol',iv, * sq//'treblelowoct%' end if else if (clefq(iv) .eq. '8') then write(11,'(a20)')sq//'resetclefsymbols' end if end if end if 17 continue if (islast) write(11,'(a)')sq//'pmxnewclefs' end if 23 continue c c Kluge \CenterBar for whole bar rests if necessary c if (newclef .and. centrests) then c write(11,'(a)')sq//'def'//sq//'value{11}%' nvalue = nint(.55*musicsize) if (nvalue .gt. 10) then write(11,'(a11,i2,a2)') * sq//'def'//sq//'value{',nvalue,'}%' else write(11,'(a11,i1,a2)') * sq//'def'//sq//'value{',nvalue,'}%' end if end if newclef = .false. centrests = .false. 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) c iornqnow = iornq(1,1) iplnow = ipl(1,1) else islnow = islur(1,nib(1,ibar-1)+1) c iornqnow = iornq(1,nib(1,ibar-1)+1) iplnow = ipl(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 c else if (btest(iornqnow,29)) then else if (btest(iplnow,0)) 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 c Reduce space before mbrest at start of system c Need this even if no accidentals in key signature c if (ibar.eq.ibarmbr) xb4mbr = -.2*musicsize 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 .and. ignorenats) * write(11,'(a)')sq//'ignorenats%' 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 if (islast .and. bottopgap) then if (abs(botamt) .gt. 1.e-6) then if (botamt .gt. 9.95) then fmtq = '(a,f4.1,a)' else if (botamt .gt. 0.) then fmtq = '(a,f3.1,a)' else if (botamt .gt. -9.95) then fmtq = '(a,f4.1,a)' else fmtq = '(a,f5.1,a)' end if write(11,fmtq)sq//'null'//sq//'vskip',botamt, * sq//'Internote%' end if end if 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%' if (islast .and. bottopgap) then if (abs(topamt) .gt. 1.e-6) then if (topamt .gt. 9.95) then fmtq = '(a,f4.1,a)' else if (topamt .gt. 0.) then fmtq = '(a,f3.1,a)' else if (topamt .gt. -9.95) then fmtq = '(a,f4.1,a)' else fmtq = '(a,f5.1,a)' end if write(11,fmtq)sq//'null'//sq//'vskip',topamt, * sq//'Internote%' end if bottopgap = .false. end if 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 (is4bignv) xinsnow = .95*xinsnow 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 = -.2*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) if (ignorenats) write(11,'(a)')sq//'ignorenats%' 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) if (ignorenats) write(11,'(a)')sq//'ignorenats%' write(11,'(a)')sq//'zchangecontext' end if else if (islast .and. ignorenats) * write(11,'(a)')sq//'ignorenats%' 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 = -.2*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 if (ignorenats) write(11,'(a)')sq//'ignorenats%' 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 c xb4mbr = (facmtr+naccs*.24)*musicsize xb4mbr = -.2*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 .and. ignorenats) * write(11,'(a)')sq//'ignorenats%' 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 c xb4mbr = naccs*.24*musicsize xb4mbr = -.2*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) then c if (mbrest .gt. 0) then cc write(11,'(a)')sq//'addspace{-2'//sq// cc * 'afterruleskip}'//sq//'setemptybar'//sq//'bar' c write(11,'(a)')sq//'setemptybar'//sq//'bar'//sq// c * 'advance'//sq//'barno-1%' c end if write(11,'(a,2i1,a)')sq//'newtimes0%' end if c if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize if (ibar .eq. ibarmbr) xb4mbr = -.2*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) 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 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 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) 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) ivx = iand(31,idynd) 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 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) ivvfig(ivx,jfig-islide) = ivvfig(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}%' c c This was causing an incorrect poe in an example, which did not affect main c spacing, but did cause an extra accidental space to be too small c 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 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 if (islast .and. bottopgap) then if (abs(botamt) .gt. 1.e-6) then if (botamt .gt. 9.95) then fmtq = '(a,f4.1,a)' else if (botamt .gt. 0.) then fmtq = '(a,f3.1,a)' else if (botamt .gt. -9.95) then fmtq = '(a,f4.1,a)' else fmtq = '(a,f5.1,a)' end if write(11,fmtq)sq//'null'//sq//'vskip',botamt, * sq//'Internote%' end if end if 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 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) parameter (nm=24) 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) common /commvl/ nvmx(nm),ivmx(nm,2),ivx logical lowdot,IsArpShift character*80 soutq character*79 notexq character*8 symq(2) character*1 chax data symq /'raisearp','arpeggio'/ c c NOTE iv in arg list is really ivx, referring to voice rather than staff. 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, narp 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 voice. c levbot = min(levar1(iarp),nolev)-ncm+3 invert = abs(levar1(iarp)-nolev)+1 else c c Arp covers >1 voice. Lower voice has to be the first, upper is current and c is where the symbol will be written. c Check whether ivx's ivar1(iarp) & iv are in same staff c do 5 iiv = 1 , nm if (ivmx(iiv,1).eq.ivar1(iarp) .or. (nvmx(iiv).eq.2.and. * ivmx(iiv,2).eq.ivar1(iarp))) then iivivx1 = iiv go to 6 end if 5 continue print*,'Screwup#1 in putarp' stop 6 continue do 7 iiv = 1 , nm if (ivmx(iiv,1).eq.iv .or. (nvmx(iiv).eq.2.and. * ivmx(iiv,2).eq.iv)) go to 8 c c Found iv for both voices (iivivx1, iiv), done looking c 7 continue print*,'Screwup#2 in putarp' stop 8 continue if (iivivx1 .eq. iiv) then nstaffshift = 0 else nstaffshift = -nint(2*xinsnow) end if c levbot = -nint(2*xinsnow)+3+levar1(iarp)-ncmar1(iarp) levbot = nstaffshift+3+levar1(iarp)-ncmar1(iarp) invert = -levbot+4+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.81 ornament on a note, next line is top of manual loop. c 2 continue c cc Bit # of last ornament (last of bits 0-21) cc Bit # of last ornament (last of bits 0-24) c Bit # of last ornament (last of bits 0-24,29-30) if (btest(iornq,29)) then ibit = 29 else if (btest(iornq,30)) then ibit = 30 else ibit = log2(iand(iornq,4194303)) c ibit = log2(iand(iornq,33554431)) end if 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 and 29-30: C (coda), G (new segno) 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 if (ibit.eq.29 .or. ibit.eq.30) then c c coda or new segno, no height tweak c ihorn = 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 else if (btest(iornt,29)) then notexq = sq//'ccoda' lnote = 6 else if (btest(iornt,30)) then notexq = sq//'ssegno' lnote = 7 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 c if (ibit .lt. 21) then c if (ibit.lt.21 .or. ibit.eq.29) then if (ibit.lt.21 .or. ibit.eq.29 .or. ibit.eq.30) 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 bit 29 or 30 had been set, would have been used first time thru, c and you wouldn't use both coda and segno on same note 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, c * eloff,iup,irest,usexnumt) * eloff,iup,irest,mult,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+igetbits(mult,8,16)-64 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=9600) character*131072 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 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() 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 if (mtrdenl.eq.8 .and. (mtrnuml.eq.8.or.mtrnuml.eq.4)) then c c Added 170726 c ibmtyp = 1 ibmrep = mtrnuml/4 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. c if (.not.btest(islur(ivx,ipb(1)),2)) then if (.not.btest(islur(ivx,ipb(1)),2) .and. nnb.gt.1) then c c No forced 0 slope c 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. 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 * -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) c * .and. .not.btest(islur(ivx,ipb(1)),2)) then * .and. .not.btest(islur(ivx,ipb(1)),2) * .and. nnb.ne.1) 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 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 c if (.not.btest(islur(ivx,ipb(1)),2)) if (.not.btest(islur(ivx,ipb(1)),2) .and. nnb.ne.1) * 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) c if (index('uldtb+-hfnHps ',durq) .gt. 0) then if (index('uldtb+-hfnHpsv ',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 if (lineq(iccount+1:iccount+1).eq.'x') then c c Flag for 2-voice, indexed slurs c iccount = iccount+1 call setbits(isdat1(nsdat),1,1,1) 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. c * kv-1 .eq. igetbits(isdat1(isdat),1,12)) then * (kv-1 .eq. igetbits(isdat1(isdat),1,12) * .or. btest(isdat1(isdat),1))) 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 else if (durq .eq. 'v') then ! Stem slur isdat1(nsdat) = ibset(isdat1(nsdat),2) 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,clefqiv 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) common /comis4bignv/ is4bignv,AIset logical is4bignv,AIset 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 c 130324 c iiv = 1 do 5 iinst = 1 , noinst c if (isize(iiv) .eq. 1) then if (isize(iinst) .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 c else if (isize(iiv) .eq. 2) then else if (isize(iinst) .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 c iiv = iiv+nsperi(iinst) 5 continue 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 clefqiv = clefq(iv) if (clefqiv.eq.'8') then clefqiv='t' iTransAmt(instno(iv)) = 7+iTransAmt(instno(iv)) end if 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 if (clefq(iv) .eq. '8') then if (iinst .lt. 10) then write(11,'(a)')sq//'settrebleclefsymbol'//chax(48+iinst)// * sq//'treblelowoct%' else write(11,'(a21,i2,a)')sq//'settrebleclefsymbol{',iinst,'}'// * sq//'treblelowoct%' end if 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 facis = 1. if (is4bignv) facis = .95 write(11,fmtq)sq//'stafftopmarg0pt'//sq//'staffbotmarg0pt' * //sq//'interstaff{',xinstf1*facis,'}'//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),noinst,iinsiv(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,icmm(0:15) character*5 versionc common /comver/ versionc c c These are not consecutive because channel 9 is reserved for percussion. c data icmm /0,1,2,3,4,5,6,7,8,10,11,12,13,14,15,16/ 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 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 c Add 3 for instrum, 4 for bal, plus 4 (for closing) to byte count, c 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) c * //char(0)//char(12*16+icmm(icm))//char(midinst(iv)) * //char(0)//char(12*16+icmm(icm))//char(midinst(iinsiv(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)), c * ichar(byteq(1)),0,12*16+icmm(icm),midinst(iv), * ichar(byteq(1)),0,12*16+icmm(icm),midinst(iinsiv(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(iinsiv(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,nclef) c subroutine wsclef(iv,ninow,clefq,nclef) c c Writes \setclef for instrument containing *staff* iv c parameter (nm=24) common /comlast/ islast,usevshrink logical islast,usevshrink common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm) logical rename c c In pmx271, had removed clefq, so with 2 or more staves in c an instrument, had problems. So replace in 272 c common /comclefq/ clefq(nm) character*1 clefq,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 c c Here, iinst is the instrument number with staff of clef change c 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 c c Only one staff (iv) in instrument with clef change c write(11,'(a)')temq(1:ltem)//clefq(iv)//'%' else temq = temq(1:ltem)//'{' ltem = ltem+1 c c Loop over staves, but clefq has only changed for one of them c 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 subroutine chkpmxlyr(lineq,iccount,lyrerr) character*128 lineq character*1 charq lyrerr = 0 c c On entry, last char was " c 18 call g1etchar(lineq,iccount,charq) if (iccount .eq. 121) then lyrerr = 2 return c else if (charq.eq.'"') then else if (charq.eq.'"' .and. * .not.(lineq(iccount-1:iccount-1).eq.char(92))) then call g1etchar(lineq,iccount,charq) c c Check for raise/lower command c if (charq .eq. '@') then c c @ positions lyrics vertically for current voice c [a,b] above or below of the staff c +/- i offset, \internotes c call g1etchar(lineq,iccount,charq) if (index('ab',charq).eq.0) then lyrerr = 3 return end if call g1etchar(lineq,iccount,charq) if (index('+-',charq).eq.0) then lyrerr = 4 return end if call g1etchar(lineq,iccount,charq) if (index('0123456789',charq).eq.0) then lyrerr = 5 return end if else if (charq .ne. ' ') then c c 2nd " must be followed by ' ' c lyrerr = 1 return end if return end if go to 18 end subroutine dopmxlyr(lineq,iccount) c c lineq has " at iccount. Find end of lyrics string, replace "..." c with \pmxlyr{...}\, but also look for ~ in lyrics and replace with '\ll ', c (unless preceded with '\'), check length c character*128 lineq,lineqt character*1 sq /'\'/ iend = lenstr(lineq,128) c c i2nd = iccount+index(lineq(iccount+1:128),'"') c Find position of closing '"'; must bypass any \" which is used for umlaut c i2nd = iccount+index(lineq(iccount+1:128),'"') 2 continue if (lineq(i2nd-1:i2nd-1).eq.char(92)) then i2nd = i2nd+index(lineq(i2nd+1:128),'"') go to 2 end if istart = iccount 1 itilde = istart+index(lineq(istart+1:i2nd-1),'~') if (itilde.gt.istart.and.itilde.lt.i2nd) then c c Replace tilde if not preceded by \ c if (iend .ge. 117) then print*,'Sorry, lyric string is too long, stopping' call stop1() else if (lineq(itilde-1:itilde-1) .eq. sq) then istart = itilde go to 1 end if lineqt = lineq(1:itilde-1)//sq//'lk ' * //lineq(itilde+1:iend) iend = lenstr(lineqt,128) i2nd = i2nd+3 lineq = lineqt go to 1 end if if (iccount .eq. 1) then lineqt = sq//'pmxlyr{'//lineq(2:i2nd-1)//'}'//sq * //lineq(i2nd+1:128) else lineqt = lineq(1:iccount-1)//sq//'pmxlyr{' * //lineq(iccount+1:i2nd-1)//'}'//sq * //lineq(i2nd+1:128) end if i2nd = i2nd+8 lineq = lineqt if (lineq(i2nd+1:i2nd+1) .eq. '@') then lineqt = lineq(1:i2nd)//'at{'//lineq(i2nd+2:i2nd+4)//'}'//sq * //lineq(i2nd+5:128) lineq = lineqt end if return end