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