File: pmxb.for

package info (click to toggle)
pmx 1.3.8-3
links: PTS
area: contrib
in suites: slink
size: 1,376 kB
ctags: 905
sloc: sh: 115; makefile: 103; sed: 4
file content (10193 lines) | stat: -rw-r--r-- 329,851 bytes
cccccccccccccccccccccccccccccccccccc
cc
cc  pmxb.for Version 1.3.8 5/9/98  
cc
ccccccccccccccccccccccccccccccc
cc
cc Need to do
cc     
cc  Add staves/instrument to manual
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  Whole-bar rests with double lines of music
cc  Print both sets of bar #'s in tex file.
cc  Make barlines invisible \def\xbar{\empty} , fix fbar.
cc  Print meter change before page break
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  Accidentals on left-shifted chord note not shifted?
cc  Tighten test for M as macro terminator.
cc  Rests in xtuplets.
cc  Fix title so not separate limit on author length + composer length.
cc  Arpeggios in xtups.
cc
cc ver138: 
cc  More work on doublebars at end of movement or piece.
cc  Enable Rd, Rr, RD at end of an input block, without movement break.
cc  Get AI, Ai to work properly in first page.
cc ver1372
cc  Fix end-level inheritance.
cc  Fix st (forgot it is kv-1 stored in isdat)
cc  Fix Rd, RD, Rr AGAIN
cc ver1371
cc  Fix doublebar etc. at end of movements and end of piece
cc  Fix bug with repeated ornament heights in beams, replicate iornq(23) 
cc  use iv and kv as slur data (not ivx) for coordinating across input blocks.
cc  use iv and kv in ndlev (not ivx) for coordinating pitch across input blocks.
cc    (fixes Begemann bug with Grace note)
cc mx01b (ver 1.3.7)
cc  Fix bug in multiple (A (B c4 , replaced preslur by npreslur.
cc ver1363
cc  alter auto slur-height adjustment with _ or . so user-defined adjustments
cc     are relative.
cc  change \usf (>) to \lsf if user-defined ivoff <-7
cc ver136
cc  >19 beats per bar, alternate meter syntax e.g. m23/16/12/8 
cc  Expand binary mask to include ornaments >^
cc  Enable ornrpt in xtup. 
cc ver135
cc  Fix t-slur auto height change.
cc  Fix o> in xtups in pmxa
cc  Fix repeated ornament by making durq=' '
cc  Disallow rx3 in pmxa
cc mx99
cc  Fix bug in floating figure: increase format to 2 decimals
cc  ver134
cc  Placeholder figure '_'
cc mx98b
cc  Force beam multiplicity (m[digit], flag in islur bit 21, value in 22-24)
cc  Tie slurs 'st' (isdat2,bit3)
cc  \stdstemfalse with graces. (all in pmx.tex, \shlft and \gaft)
cc  Force 0-slope beam. 'sh'?  (uses islur bit 2)
cc  Fix minor bug in call getfig (itsofar not dimensioned in sub).
cc  Fix minor bug (mixed type args) in ihorn = min or max(...)
cc  Restrict slur ID codes to caps or numbers.
cc pmx133
cc  Double whole notes
cc mx97
cc  slurs with external ID.
cc mx96
cc  Error Trap for figure before 1st note in a notes group.
cc  Error Trap for e.g. x19 7
cc pmx132b
cc  Fix bug in 6-character figures (e.g., #2#4n6)
cc mx95b
cc  Fix meter-only change at end of line to repeat meter at end & start.
cc  Fix meter+sig changes midline, end-of-line mid page (repeat both).
cc  Rework Ai, AI
cc  Clef change after movement break
cc  Add ornaments >, ^.
cc pmx131b
cc  split makeabar in two.
cc mx94  
cc  Key signature/transposition bugs fixed here and in pmxa by defining idsig.
cc  Fixed centered whole-bar rest fermata bug by defining cwrferm(iv)
cc  Use subroutine getorn to input ornaments.
cc  Reorder iornq
cc mx93
cc  Include o( in binary mask for ornament repeat toggle. 
cc  Leave space for o( as if it were and accidental.
cc  Special treatment in pmxa of Ai at start, so it gets handled in topfile. 
cc  Set interstaff with Ai[x] where [x] is decimal fraction.
cc  Arbitrary # voices per inst: use noinst<0, then nvi(1,...,-noinst)
cc  Bug fix for graces with slurs when nnl(ivx)=0
cc  Chords in xtups
cc  Need to fix o( o) on dotted half note. 
cc  Need to check flag spaces at end of line.
cc  Need to raise ornaments if on an up-slurred grace.
cc mx92
cc  Correct width of brace above xtup for asx's
cc  Enable user-define spaces in xtups
cc  Check for crashes with right-shifted chord notes (rtshfac, not in xtups)
cc  Fix moveable dots in normal and shifted chord notes
cc  Raise ornaments if slur start or stop. 
cc  Reverse order of inserting ornaments and slur/graces
cc Ver 1.25
cc  Enabled hardspace at end of bar.
cc  User-defined shifts   X(number)[p]: =>on, X: =>off
cc  Macro Saves (record but don't execute)    MS(integer)  Fix scor2prt
cc  Parameterize # of notes/line/input block; check it (pmxa) 
cc  "o(orn):" = start ornament rpt, "o:" = stop it.
cc  put orn rpts in xtups
cc Ver 1.24
cc  Change width of format for slur horiz adjustment when shift<-0.95
cc  Redefine ornament height in chords. 
cc  Movement breaks.
cc  Fix slurs + o.
cc Ver 1.23
cc  Ornament repeat toggle is ":"; if turning on, must come after ornament 
cc  Flip xtup number.
cc  Fine-tune height, horiz pos'n of xtup number
cc  replace rest by irest
cc  Re-order checks on stem-directions for determining slur shifts.
cc  Version 1.23 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 Ver 1.22
cc   Arpeggios '?'.
cc Ver 1.21 
cc   Editorial accidentals: "oes,f,n" (treated like accid.'s, print above note) 
cc   Parse setup data from full lines: permit up-front TeX (start & end with
cc        '---' at start of a line)  & permit comments in setup.
cc   Enable midbar Rd .
cc   Shortcut 2:1 rhythms, e.g., a4,b = a4 b8
cc
ccccccccccccccccccccccccccccccc
      parameter (nm=7)
c
c  FYI /all/ differs in appearance in function ncmid
c
            common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
c  Bits 1-13: stmgx+Tupf._)  14: Down fermata, was F  15: Trill w/o "tr", was U
c
c  islur is used as a bank of switches
c  
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  Unused
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  Unused
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
c
c
c  Bit values for 2nd bank of switches, ipl
c
c  0-7   Location in list [0,200]
c  8     \loff 
c  9     \roff 
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  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) 
c
c  Set up iornq as bitmap.
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    New ornaments TBD
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  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-31 Value of horiz slur shift, 0...15 => -.8,...,-.1,+.1,...,+.8
c
c   And now irest is also a set of switches
c
c  0        rest=1, no rest = 0        
c  1        There will be a vertical shift for number of this xtup
c  2-6      Height shift, 1 => -15, 31 => +15  Indicate by +/- [n] after 'n'
c  7        There is a horizontal shift for xtup number
c  9-13     Horiz shift, 1=>-1.5, ... , 31=>+1.5
c  14       Flip up/down-ness of xtup number
c  15       Single-voice, single note shift  X(...)[p]S
c  16       Start single-voice, multinote shift with this note X(...)[p]:
c  17       End single-voice, multinote shift after this note. Enter symbol
c              after note. X:
c  18       User-defined hardspace after last note of bar, *after* this note.
c              Value still stored in udoff(ivx,nudoff(ivx)), not with other
c              hardspaces in udsp, to avoid confusion with time checks.
c  19       Move the dot.  Data stored in ndotmv,updot,rtdot
c  20       Set if right-shifted 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  
c  isdat1: Slur information
c
cc  0-2      ivx
c  0-2      iv
c  3-10     ip
c  11       start/stop switch
c+
c  12       kv
c+
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  isdat2
c
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  6-11     voff1 1-63  =>  -31...+31
c  12-18    hoff1 1-127 => -6.3...+6.3
c  19-25    nolev
c
cccccccccccccccccccccccccccccccc
      character*6 figq
      character*1 accq,ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,
     *        isfig,rptnd1,rptprev
      logical loop,lastchar,slint,svolta,evolta,onvolt,xtupb4,
     *        cwrest(nm)
      integer nsystp(20),nindex(20),istop(20),n1xtup(20),numbms(nm),
     *        istart(20),lbxtup(20),itstart(20)
      real*4 xnsttop(20),xintstaff(20),hesk(19),hpts(19)
      character*1  clefq(nm),ulfbq,accgq,rptfq1,rptfq2
      character*79 notexq,inameq
      character*40 pathnameq
      character*24 basenameq,fmtq
      character*10 voltxtq
      character*6 nstartq(15)
      character*60 instrq,titleq,compoq
      common /combjmp/ ivbjmp,isbjmp
      common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
     *    inhead,inbothd
      common /comfig/ itfig(74),figq(74),nfigs
      common /comnsp/ nspace(20),nb,xtfold(nm),xtupb4,lastnodur(nm),
     *    flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
      common /comstart/ nstartq,lstart(15),facmtr
      common /comfb/ nfb(nm),it1fb(nm,20),it2fb(nm,20),ulfbq(nm,20),ifb
      common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,
     *       movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
     *       rptprev,rptfq1,rptfq2
      common /combeam/ ibmtyp
      common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd,
     *                npreslur,was2(nm)
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,inameq(nm),idsig
      common /comas1/ naskb,itask(20),wask(20),elask(20),iasxb,
     *                nasxb,ipasx(20),ivasx(20),wasx(20),elasx(20)
      common /comas2/ nasksys,wasksys(400),elasksys(400),
     *                nasxsys,wasxsys(100),elasxsys(100)
      common /comas3/ ask(1000),iask,asx(200),iasx,topmods
      common /comask/ bar1syst,fixednew,scaldold,apt,abigpt,
     *                wheadpt,fbar,poenom
      common /comslur/ listslur,upslur(nm,2),ndxslur
      common /comsln/ is1n1,is2n1,irzbnd,isnx
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),aftshft,
     *                nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
     *                noffseg,ngrace,nvolt,ivlit(36),iplit(36),nlit,
     *                lenlit(36),multg(37),upg(37),slurg(37),slashg(37),
     *                accgq(74),voltxtq(6),litq(36)
      logical upg,slurg,slashg,fbon,ornrpt,shifton,isbjmp,notcrd,was2
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      character*128 litq,lnholdq
      logical upslur,bar1syst,vshrink,lrpt,rrpt,lrptpend,endon,
     *   ispoi,bcspec,topmods,headlog,clchb,clchv(nm),flgndb,
     *   btest,sluron,setis
      common /comcc/ ncc(nm),itcc(nm,10),ncmidcc(nm,10),
     *               ndotmv(nm),updot(nm,20),rtdot(nm,20)
      common /compoi/ ispoi
      common /combc/ bcspec
      common /comeon/ eonk,ewmxk
      common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
     *                flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac, 
     *                rtshfac
      common /comhsp/ hpttot(176)
      common /combmh/ bmhgt,clefend
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtrans/ ntrans
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      common /comudsp/udsp(25),itudsp(25),nudsp,udoff(nm,20),nudoff(nm),
     *                 uxsp(25),ivuxsp(25),ipuxsp(25),nuxsp
      common /strtmid/ ihnum3,flipend(nm)
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      common /comnvi/ nvi(nm)
      logical mrecord,mplay,endmac,flipend,istype0,lowdot
      slfac1 = 0.00569  
      stemmax = 8.2 
      stemmin = 3.9
      stemlen = 6.0
      sq = char(92)      
      bcspec = .true.
      topmods = .false.
      open(12,file='pmxtex.dat')
      read(12,'(a)')basenameq
      read(12,*)lbase
      read(12,*)fbar,apt,abigpt,wheadpt,etait,etatc,etacs1,etatop,
     *         etabot,inbothd,inhnoh,isig
      open(10,file=basenameq(1:lbase)//'.pmx')
      call getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0,
     *            npages,nsyst,musicsize,fracindent,istype0,inameq,
     *            clefq,sepsymq,pathnameq,lpath,isig0)
      read(12,*)npages,widthpt,height,nsyst,
     *   (nsystp(ipa),xnsttop(ipa),xintstaff(ipa),ipa=1,npages),iauto
      open(13,file='pmxtex.fig')
      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')
      call topfile(basenameq,lbase,nv,clefq,noinst,musicsize,
     *      xintstaff(1),mtrnmp,mtrdnp,vshrink,fbar)
c
c  Save original printed meter in case movement breaks 
c
      movnmp = mtrnmp
      movdnp = mtrdnp
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
      if (figbass .and. musicsize.eq.16) write(11,'(a)')sq//'font'
     *    //sq//'figfont=cmr8%'
      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 = xmtrnum0*lenbeat+.5
      if (mtrdenl .eq. 2) lenb0 = lenb0*2
      if (lenb0 .ne. 0) then
        write(11,'(a)')sq//'advance'//sq//'barno by -1'
        lenbar = lenb0
      else
        lenbar = lenb1
      end if
c
c  Initialize system fixed space (pt), removed scalable space (elsk), naskb
c
      fixednew = 0.
      scaldold = 0.
      fintstf = -1.
      gintstf = 1.
      nasksys = 0
      nasxsys = 0
      ibarcnt = 0
      iline = 0
      movbrk = 0
      isystpg = 0
      ipage = 1
      iccount = 128
      iask = 0
      iasx = 0
      nhstot = 0
      jprntb = 81
      idsig = 0
c
c  Switch bank for which notes groups have been defined.  Runs for whole piece.
c
      nregon = 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
      ispoi = .false.
      slint = .false.
      lrptpend = .false.
      rptnd1 = .false.
      rptfq2 = 'E'
      rptprev = .false.
      endon = .false.
      onvolt = .false.
      flgndb = .false.
      fbon = .false.
      shifton = .false.
      ornrpt = .false.
      setis = .false.
      notcrd = .true.
      lowdot = .false.
      npreslur = 0
      nhssys = 0
      listslur = 0
c      do 1 ivx = 1 , nm
c        ndxslur(ivx,1) = 0
c        ndxslur(ivx,2) = 0
c1     continue
      do 31 i = 1 , 101
        isdat1(i) = 0
        isdat2(i) = 0
31    continue
      nsdat = 0
c
c  Initialize for loop over gulps
c
      firstgulp = .true.
c
c  Start a gulp
c
30    loop = .true.
      nbars = 0
      nfigs = 0
      ngrace = 0
      ntrill = 0
      ncrd = 0
      nudorn = 0
      nlit = 0
      nvolt = 0
      ibarmbr = 0
      nudsp = 0
      nuxsp = 0
c
c  Now initialize up to nv.  Do it in getnote as r'qd for 2nd voices per syst.
c
3     do 4 iv = 1 , nv
        nvmx(iv) = 1
        ivmx(iv,1) = iv
        itsofar(iv) = 0
        nnl(iv) = 0
        nfb(iv) = 0
        if (firstgulp) then
          ncmidcc(iv,1) = ncmidf(clefq(iv))
        else
          ncmidcc(iv,1) = ncmidcc(iv,ncc(iv))
        end if
        itcc(iv,1) = 0
        ncc(iv) = 1
        nudoff(iv) = 0
        ndotmv(iv) = 0
        do 5 j = 1 , 200
          irest(iv,j) = 0
          islur(iv,j) = 0
          ipl(iv,j) = 0
          accq(iv,j) = 'x'
          iornq(iv,j) = 0.
          if (iv.eq.1) isfig(j) = .false.
5       continue
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
      nvolt = 0
      do 28 iv = 1 , nm
        nudoff(iv) = 0
        ndotmv(iv) = 0
28    continue
c
c  Put in titles at top of p.1.  Must wait until now to have read title info.
c 
      if (ibarcnt .eq. 0) call puttitle(inhnoh,xnsttop(ipage),
     *     etatop,sq,etait,etatc,etacs1,nv,vshrink,sepsymq)
      do 10 ibar = 1 , nbars
        ibarcnt = ibarcnt+1
        bar1syst = ibarcnt .eq. iauto
        write(11,'(a5,i3)')'% bar',ibarcnt+ibcoff
        if (ibar .ne. ibarmbr) then
          call outbar(ibarcnt+ibcoff,jprntb)
        else
          write(*,'(/,a19,i4,a1,i4)')' Multibar rest, bars',
     *       ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1
          jprntb = 0
          ibcoff = ibcoff+mbrest-1
          if (ibar.eq.1 .and. firstgulp) xb4mbr = facmtr*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)
        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)
            lastnodur(ivx) = nodur(ivx,ip)
c
c If ibar=1 (1st bar in input block), lastnodur(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 (lastnodur(iv) .eq. nspace(nb)) 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(float(nspace(nb)))
        ptsdflt = esk*poenom-wheadpt
        if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0) then
c
c  Must ADD hardspace!  So put in a placeholder, and store params for later.
c
          write(11,'(a)')sq//'xardspace{    pt}%'
          nhssys = nhssys+1
          if (ptsndb-ptsdflt .gt. ptsgnd-poenom*eskgnd) then
            hesk(nhssys) = esk
            hpts(nhssys) = ptsndb+wheadpt
          else
            hesk(nhssys) = eskgnd
            hpts(nhssys) = ptsgnd+wheadpt
          end if
          fixednew = fixednew+hpts(nhssys)
          scaldold = scaldold+hesk(nhssys)
        end if
        if (clchb) then
          do 17 iv = 1 , nv
            if (clchv(iv)) then
              notexq = sq//'znotes'
              lnote = 7
              do 24 iiv = 2 , iv
                notexq = notexq(1:lnote)//sepsymq(iiv-1)
                lnote = lnote+1
24            continue
c
c  Recompute ioff since it will vary from voice to voice
c
              if (ibar .eq. 1) then
                ioff = 0
              else
                ioff = nib(iv,ibar-1)
              end if
c
c  Must call clefsym to get nclef, even if there is a movement break
c
              call clefsym(islur(iv,ioff+1),fmtq,lclef,nclef)
              if (movbrk.eq.0) 
     *          write(11,'(a)')notexq(1:lnote)//fmtq(1:lclef)//sq//'en%'
              call wsclef(iv,nv,noinst,clefq,nclef)
            end if
17        continue
          write(11,'(a)')sq//'pmxnewclefs'
        end if
23      continue
c
c  End of loop for end-of-bar hardspaces and non-movbrk clef symbol.
c
        if (bar1syst) read(12,*) poenom
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)
        else
          islnow = islur(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
            print*
            print*,'Illegal symbol with "R" at end of input block:',
     *        rptfq2
            stop 1
          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
              write(11,'(a)')sq//'setleftrightrepeat'
              fixednew = fixednew+wheadpt*lrrptfac-0.4
            else
              write(11,'(a)')sq//'setleftrepeat'
              fixednew = fixednew+wheadpt*rptfac-0.4
            end if
          else if (rrpt) then
            write(11,'(a)')sq//'setrightrepeat'
            fixednew = fixednew+wheadpt*rptfac-0.4
          else if (btest(islnow,8)) then
            write(11,'(a)')sq//'setdoublebar'
            fixednew = fixednew+wheadpt*dbarfac-0.4
          end if
        else if (btest(islnow,26)) then
c
c  doubleBAR
c
          write(11,'(a)')sq//'setdoubleBAR'
          fixednew = fixednew+wheadpt*ddbarfac-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
            write(11,'(a)')sq//'endvoltabox'
          else
            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
            write(11,'(a)')sq//'Setvolta'//voltxtq(nvolt)(1:1)//'%'
          else
            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
          iline = iline+1
c
c  End an old system, Start a new system
c
          if (iline .ne. 1) then
c
c  Not first line.  
c
c  Get corrected poe = points/elemskip for *previous* system
c
            wdpt = widthpt
            if (iline.eq.2 .or. movbrk.gt.0) 
     *                     wdpt = widthpt*(1-fracindent)
            poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/
     *            (elsktot+fbar*nbarss-scaldold)
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.) 
c     print*,'iask,ask,ia,wasksys,poe,elasksys:'
c     print*,iask,ask(iask),ia,wasksys(ia),poe,elasksys(ia)
9           continue
            do 8 ia = 1 , nasxsys
              iasx = iasx+1
              asx(iasx) = wasxsys(ia)/poe-elasxsys(ia)
8           continue
            do 25 ia = 1 , nhssys
              nhstot = nhstot+1
              hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.)
25          continue
c     print*,'widthpt,fsyst,musicsize,elsktot,fbar,nbarss:'
c     print*,widthpt,fsyst,musicsize,elsktot,fbar,nbarss
c     print*,'poe,fixednew,scaldold:'
c     print*,poe,fixednew,scaldold
c
c  Reset counters for new system
c
            scaldold = 0.
            fixednew = 0.
            nasksys = 0
            nasxsys = 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 (figbass) write(11,'(a)')sq//'fixdrop%'
          isystpg = isystpg+1
          if (isystpg .eq. nsystp(ipage)) isystpg = 0
          read(12,*)nbarss,elsktot,fsyst,eonk,ewmxk,ieneed
c
c  Redefine notes as required.  nregon is a running bitmap of active, non-tight
c  notes def'ns in TeX file.  
c
          if (iline.eq.1) then
c
c  No checks needed; must write all requested levels. 
c
            call defnotes(ieneed)
            if (eonk .lt. .001) nregon = ieneed
          else
c
c  Not first stystem.  
c
            if (eonk .gt. .001) then
c
c  Define all necessary notes groups
c
              call defnotes(ieneed)
c
c  Unmark all groups just done from list of regulars
c
              nregon = iand(nregon,not(ieneed))              
            else
c
c  Regular values.  Get ones needed but not done. 
c
              iedo = iand(ieneed,not(nregon))
              call defnotes(iedo)
              nregon = ior(nregon,iedo)
            end if
          end if
          if (figbass) ifigdrop(iline) = 4
          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)')
     *          sq//'figdrop=',ifigdrop(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
              isn2 = 0
              ioff = 0
              if (ibar .gt. 1) ioff = nib(ivmx(nv,nvmx(nv)),ibar-1)
              do 50 isdat = 1 , nsdat
                if (igetbits(isdat1(isdat),3,0).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
                  is1n1 = max(is1n1,igetbits(isdat2(nsdat),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
                slint = .true. 
                fmtq = '(a16,i1,a14)'
                if (irzbnd+isnx .gt. 9) fmtq = '(a16,i2,a14)'
                write(11,fmtq)sq//'def'//sq//'raisebarno{',
     *             irzbnd+isnx,'.5'//sq//'internote}%'
              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('Ddr',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 "/"'
                stop 1
              end if
              if (movgap .lt. 10) then
                write(11,'(a12,2i1,a1)')
     *                sq//'newmovement',movgap,indsym,'%' 
              else
                write(11,'(a13,i2,a1,i1,a1)')
     *                sq//'newmovement{',movgap,'}',indsym,'%' 
              end if
              call wgmeter(mtrnmp,mtrdnp)
              do 60 iinst = 1 , noinst
                write(11,'(a8,i1,a3)')sq//'setname',iinst,'{}%' 
60            continue
              if (btest(iplnow,28)) then
c
c  Key signature at movement break
c
                iplnow = ibclr(iplnow,28)
                if (isig .gt. 0) then
                  write(11,'(a18,i1,a2)')sq//'generalsignature{',isig,
     *               '}%'
                else
                  write(11,'(a18,i2,a2)')sq//'generalsignature{',isig,
     *               '}%'
                end if
              end if
              if (parmov .ge. -.1) then
c
c  Resent paragraph indentation
c
                ipi = parmov*widthpt+.1
                if (ipi .lt. 10) then
                  write(11,'(a11,i1,a2)')sq//'parindent ',ipi,'pt'
                else
                  write(11,'(a11,i2,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).  Eject old page.
c
              if (onvolt) then
                write(11,'(a)')sq//'endvoltabox%'
                onvolt = .false.
              end if
c
c  Key signature change?
c
              if (btest(iplnow,28)) 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
                write(11,'(a)')notexq(1:lnote)//char(48+abs(isig))//'}%'
                write(11,'(a)')sq//'zchangecontext'//sq//'addspace{-.5'
     *              //
     *              sq//'afterruleskip}'//sq//'def'//sq//'writezbarno{}'
     *              //sq//'zstoppiece%'
              else
                write(11,'(a)')sq//'stoppiece%'
              end if   
              if (.not.vshrink) then
                xnstbot = xnsttop(ipage)*etabot/etatop
                if (xnstbot .lt. 9.95) then
                  fmtq = '(a,f3.1,a)'
                else
                  fmtq = '(a,f4.1,a)'
                end if
c               write(11,fmtq)sq//'stoppiece'//sq//'vskip',xnstbot,
                write(11,fmtq)sq//'vskip',xnstbot,
     *              sq//'Interligne'//sq//'eject%'
              else
                write(11,'(a)')
     *                sq//'vfill'//sq//'eject%'
              end if
              ipage = ipage+1
              vshrink = xintstaff(ipage) .gt. 20
              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
              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
                  call wgmeter(mtrnmp,mtrdnp)
                  if (mtrdnp .gt. 0) then
                    write(11,'(a)')sq//'newtimes2%'
                    if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize 
                  end if
                end if
              end if
c
c  If no real titles here, which there probably will never be, make vertical 
c  space at page top with \titles{...}.  headlog=.false.<=>no real titles
c
              call puttitle(inhnoh,xnsttop(ipage),etatop,
     *           sq,etait,etatc,etacs1,nv,vshrink,sepsymq)
            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
                write(11,'(a)')notexq(1:lnote)//char(48+abs(isig))//'}%'
                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)
                  call wgmeter(mtrnmp,mtrdnp)
                  write(11,'(a)')sq//'xchangecontext'//sq//
     *              'addspace{-'//sq//'afterruleskip}'//sq//'def'
     *              //sq//'writezbarno{}'//sq//'zalaligne%'
                  write(11,'(a)')sq//'addspace{-'//sq//'afterruleskip}%'
                  call wgmeter(mtrnmp,mtrdnp)
                  write(11,'(a)')sq//'zchangecontext'
                else
                  write(11,'(a)')sq//'xchangecontext'//sq//
     *               'addspace{-.5'//sq//'afterruleskip}'//sq//'def'//
     *               sq//'writezbarno{}'//sq//'zalaligne%'
                end if 
              else if (mtrnuml .eq. 0) then
c
c  No meter change
c
                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
                  call wgmeter(mtrnmp,mtrdnp)
                  if (mtrdnp .gt. 0) then
                    write(11,'(a)')sq//'let'//sq//'bnat'//sq//'barnoadd'
     *                //sq//'def'//sq//'barnoadd{'//sq//'empty}%'
                    write(11,'(a)')sq//'xchangecontext'//sq//
     *                'addspace{-\afterruleskip}'//sq//'zalaligne'//
     *                 sq//'let'//sq//'barnoadd'//sq//'bnat'
                    call wgmeter(mtrnmp,mtrdnp)
                    write(11,'(a)')sq//'addspace{-\afterruleskip}'//
     *                sq//'zchangecontext'
                    if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize 
                  else
                    write(11,'(a)')sq//'alaligne'
                  end if
                else
                  write(11,'(a)')sq//'alaligne'
                end if
              end if
            end if
            if (slint) then
              slint = .false. 
              write(11,'(a16,i1,a14)')sq//'def'//sq//
     *              'raisebarno{',irzbnd,'.5'//sq//'internote}%'
            end if
            movbrk = 0
          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
        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)
              call wgmeter(mtrnmp,mtrdnp)
              notexq = sq//'generalsignature{'
              lnote = 18
              if (isig .lt. 0) then
                notexq = notexq(1:18)//'-'
                lnote = 19
              end if
              write(11,'(a)')notexq(1:lnote)//char(48+abs(isig))//'}%'
              write(11,'(a)')sq//'xchangecontext%'
            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
              write(11,'(a)')notexq(1:lnote)//char(48+abs(isig))//'}%'
              write(11,'(a)')sq//'zchangecontext'//sq//'addspace{-.5'//
     *              sq//'afterruleskip}%'
            end if 
          else if (mtrnuml .eq. 0) then
c
c  No meter change
c
            write(11,'(a)')sq//'xbar'
          else
c
c  Change meter midline
c
            call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
            if (movbrk .eq. 0) then
              call wgmeter(mtrnmp,mtrdnp)
              if (mtrdnp .gt. 0) then
                write(11,'(a,2i1,a)')sq//'newtimes0%'
                if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize 
              else
                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
          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)
              accq(ivx,ip) = accq(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)
              if (ivx.eq.1 .and. figbass) isfig(ip) = isfig(ip+ioff)
12          continue
            if (ivx.le.nv .and. ncc(iv).gt.1) then
              islide = 0
              do 13 icc = 1 , ncc(iv)
                if (itcc(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
                  itcc(iv,icc-islide) = itcc(iv,icc)-lenbar
                  ncmidcc(iv,icc-islide) = ncmidcc(iv,icc)
                end if
13            continue
              ncc(iv) = ncc(iv)-islide
              itcc(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))
            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 = iand(15,ishft(kudorn(iudorn),-8))
            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 41 isdat = 1 , nsdat
c      print*
c      print*,'Before slide'
c      call report(nsdat,isdat1,isdat2)
            isdata = isdat1(isdat)
c            ivx = iand(7,isdata)
            ivx = ivmx(iand(7,isdata),igetbits(isdata,1,12)+1)
c      print*,'iv,kv,nvmx,ivx:',
c     *iand(7,isdata),igetbits(isdata,1,12)+1,nvmx(iand(7,isdata)),ivx
            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
c      print*
c      print*,'After slide'
c      call report(nsdat,isdat1,isdat2)
41        continue
          do 6 iuxsp = 1 , nuxsp
            ipnew = ipuxsp(iuxsp)-nib(ivuxsp(iuxsp),ibar-1)
            if (ibar .gt. 2) ipnew = ipnew+nib(ivuxsp(iuxsp),ibar-2)
            ipuxsp(iuxsp) = dim(ipnew,0)
c
c  This sets ipuxsp=0 for already used ones, and reduces it for others
c 
6         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
          if (figbass) then
            islide = 0
            do 20 jfig = 1 , nfigs
              if (itfig(jfig) .lt. lenbar) then
c
c  This figure was already used
c
                islide = jfig
              else
                itfig(jfig-islide) = itfig(jfig)-lenbar
                figq(jfig-islide) = figq(jfig)
                itoff(jfig-islide) = itoff(jfig)
              end if
20          continue
            nfigs = nfigs-islide
          end if
        end if
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
        call make1bar(ibmrep,nbxtup,itglp1,itstart,cwrest,
     *      nindex,istop,n1xtup,numbms,istart,nxtup,lbxtup)
        call make2bar(noinst,nbxtup,itglp1,itstart,cwrest,
     *      nindex,istop,n1xtup,numbms,istart,nxtup,lbxtup,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
          write(11,'(a11,f5.1,a4)')sq//'hardspace{',hardb4,'pt}%'
          fixednew = fixednew-hardb4
        end if
10    continue
      firstgulp = .false.
      lenb0 = 0
      go to 30
40    close(12)
      close(13)
      close(10)
      wdpt = widthpt
      if (iline .eq. 1) wdpt = widthpt*(1-fracindent)
      poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/
     *            (elsktot+fbar*nbarss-scaldold)
      do 19 ia = 1 , nasksys
        iask = iask+1
c       ask(iask) = wasksys(ia)/poe-elasksys(ia)
        ask(iask) = wasksys(ia)/poe-abs(elasksys(ia))
        if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.) 
c     print*,'iask,ask,ia,wasksys,poe,elasksys:'
c     print*,iask,ask(iask),ia,wasksys(ia),poe,elasksys(ia)
19    continue
      do 18 ia = 1 , nasxsys
        iasx = iasx+1
        asx(iasx) = wasxsys(ia)/poe-elasxsys(ia)
18    continue
      do 26 ia = 1 , nhssys
        nhstot = nhstot+1
        hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.)
26    continue
      if (onvolt) write(11,'(a)')sq//'endvoltabox'
      if (rptfq2 .ne. 'E') then
c 
c Terminal repeat.  Right or double?
c 
        if (rptfq2 .eq. 'r') then
          write(11,'(a)')sq//'setrightrepeat'//sq//'endpiece'
        else if (rptfq2 .eq. 'd') then
          write(11,'(a)')sq//'setdoublebar'//sq//'endpiece'
        else
          print*,'R? , ? not "d" or "r", rptfq2:',rptfq2
        end if
      else
        write(11,'(a)')sq//'Endpiece'
      end if
      if (.not.vshrink) then
        xnstbot = xnsttop(ipage)*etabot/etatop
        if (xnstbot .lt. 9.95) then
          fmtq = '(a,f3.1,a)'
        else
          fmtq = '(a,f4.1,a)'
        end if
        write(11,fmtq)sq//'vskip',xnstbot,
     *    sq//'Interligne'//sq//'eject'//sq//'endmuflex'
        write(11,'(a)')sq//'bye'
      else
        write(11,'(a)')
     *    sq//'vfill'//sq//'eject'//sq//'endmuflex'
        write(11,'(a)')sq//'bye'
      end if
      rewind(11)
      if (figbass) then
        write(14,'(a9,i2,a10)')sq//'figdrop=',ifigdrop(iline),sq//'fi}%'
        rewind(14)
      end if
      call askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0)
      print*
      print*,'Done with second pass.  Now run TeX'
      end
      subroutine make2bar(noinst,nbxtup,itglp1,itstart,cwrest,
     *    nindex,istop,n1xtup,numbms,istart,nxtup,lbxtup,clefq)
      parameter (nm=7)
      common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      character*6 figq
      character*1 accq,ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,isfig,bar1syst,isbjmp
      common /combjmp/ ivbjmp,isbjmp
      common /comfig/ itfig(74),figq(74),nfigs
      common /combeam/ ibmtyp
      common /comask/ bar1syst,fixednew,scaldold,apt,abigpt,
     *                wheadpt,fbar,poenom
      common /comas1/ naskb,itask(20),wask(20),elask(20),iasxb,
     *                nasxb,ipasx(20),ivasx(20),wasx(20),elasx(20)
      common /comas2/ nasksys,wasksys(400),elasksys(400),
     *                nasxsys,wasxsys(100),elasxsys(100)
      common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
      common /comfb/ nfb(nm),it1fb(nm,20),it2fb(nm,20),ulfbq(nm,20),ifb
      common /comsln/ is1n1,is2n1,irzbnd,isnx
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),aftshft,
     *                nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
     *                noffseg,ngrace,nvolt,ivlit(36),iplit(36),nlit,
     *                lenlit(36),multg(37),upg(37),slurg(37),slashg(37),
     *                accgq(74),voltxtq(6),litq(36)
      logical upg,slurg,slashg,issig,rpndot
      character*128 litq
      common /comcc/ ncc(nm),itcc(nm,10),ncmidcc(nm,10),
     *               ndotmv(nm),updot(nm,20),rtdot(nm,20)
      integer istart(20),istop(20),itstart(20),iaskb(nm),
     *   nindex(20),numbms(nm),nornb(nm),ihornb(nm,24),
     *   n1xtup(20),lbxtup(20)
      character*1 upcaseq,ulfbq,accgq,udqq,clefq(nm),slurudq
      character*8 noteq
      character*79 cwrq,notexq,inameq
      character*10 voltxtq
      common /comoct/ noctup
      character*80 soutq,headrq,lowerq
      common /comnsp/ nspace(20),nb,xtfold(nm),xtupb4,lastnodur(nm),
     *    flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
      logical bspend,lower,cwrest(nm),inxtup,vxtup,allxtup,xtupb4,
     *        blkstart,hang,isgrace,isclef,nofirst,iscln,isdot,isflag,
     *        isacc,isxtup,isfirst,isbstrt,flgndb,btest,stemup,upslur,
     *        isgaft,cwrferm(nm),inarp,isarp,found1,isrshft,isaccs,
     *        lowdot
      real*4 ptgr(37),ptclef(5),ptsndg(nm),eskndg(nm)
      common /comxtup/ xtupfac(nm),n2xtup(20),ixtup,vxtup(nm),inxtup,
     *                 ntupv(nm),nolev1,islope,xelsk(24),eloff
      character*3 acsymq
      common /comstart/ nstartq,lstart(15),facmtr
      character*6 nstartq(15)
      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 or apt)
c  In 1.04, moved to block data subprogram
c
c      common /comslur/ listslur,ndxslur(nm,2),upslur(nm,2)
      common /comslur/ listslur,upslur(nm,2),ndxslur
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,inameq(nm),idsig
      common /comudsp/udsp(25),itudsp(25),nudsp,udoff(nm,20),nudoff(nm),
     *                 uxsp(25),ivuxsp(25),ipuxsp(25),nuxsp
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
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
        beamon(ivx) = .false.
        nornb(ivx) = 0
        iaskb(ivx) = 1
25    continue        
      iasxb = 1
      naskb = 0
      nasxb = 0
      ifig = 1
      ixtup = 0
      ibxtup = 0
      bspend = .false.
      numblx = 0
      xtupb4 = .false.
c
c  numblx = 1 when Xtup starts, and increased if Xtup goes into other blocks
c
      do 16 ib = 1 , nb
c
c  Check for segno
c
c       if (ornq(1,list(2,istart(ib))).eq.'g' .and. 
        if (btest(iornq(1,list(2,istart(ib))),4) .and. 
     *       list(1,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
            notexq = notexq(1:lnote)//'&'//sq//'segnoo'
     *               //noteq(1:lnoten)//'9'
            lnote = lnote+lnoten+9
130       continue
          write(11,'(a)')notexq(1:lnote)//sq//'en'
          lnote = 0
        end if
c
c  Check for new clefs
c
        isclef = .false.
        if (btest(islur(list(1,istart(ib)),list(2,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(list(1,in),list(2,in)),11)) then
              call wsclef(list(1,in),nv,noinst,clefq,
     *          iand(ishft(islur(list(1,in),list(2,in)),-12),7))
            end if
140       continue
          write(11,'(a)')sq//'pmxnewclefs'
          isclef = .true.
        end if
c
c  Start the notes group
c
        allxtup = .false.
        inxtup = .false.
        soutq = sq//nstartq(nindex(ib))(1:lstart(nindex(ib))) 
        lsout = 1+lstart(nindex(ib))
        if (nxtup.gt.0 .and. ibxtup.lt.nbxtup .and. 
     *                       ib.eq.lbxtup(ibxtup+1)) then
c
c  Xtup in this block. Set vxtup, xtupfac, ntupv for each voice.
c
          ibxtup = ibxtup+1
          inxtup = .true.
          numblx = 1
          maxtup = 0
          allxtup = .true.
          ithang = 0
          do 100 iv = 1 , nv
          do 100 kv = 1 , nvmx(iv)
            ivx = ivmx(iv,kv)
            xtupfac(ivx) = 1.
            vxtup(ivx) = .false.
            ntupv(ivx) = 0
c
c  Search forward for ip of first note
c
            do 109 jn = istart(ib) , istop(ib)
              if (list(1,jn) .eq. ivx) then
                ip = list(2,jn)
                go to 110
              end if
109         continue
c
c  If here, ivx has no notes in this blk, but may overhang. 
c
            go to 100           
110         continue
            if (nodur(ivx,ip) .eq. 0) then
c
c  This voice has an xtuplet. Count notes.  May go past end of current block.
c
              vxtup(ivx) = .true.
              ixtup = ixtup+1
              ntup = 2
              do 101 ip = ip+1 , 100
                if (nodur(ivx,ip) .gt. 0) go to 102
                ntup = ntup+1
101           continue
102           continue
              ntupv(ivx) = ntup
              maxtup = max(maxtup,ntup)
c
c  Following will be repeated if >1 xtup, but all must span same *total* time
c
              nodurx = nodur(ivx,ip)
            else 
              allxtup = .false.
            end if
100       continue
          elxtup = maxtup*feon(nodurx/1./maxtup)
          itndxtup = list(3,n1xtup(ixtup))+nodurx
          fxtup = elxtup/feon(float(nspace(ib)))/maxtup
c
c  Above fxtup is m-n-s based on maxtup, as if maxtup dominates length.
c  allxtup true => each voice xtup or empty in this blk. May still hang.
c
          hang = .false.
          if (allxtup .and. ib.lt.nb) then
            do 113 iv = 1 , nv
            do 113 kv = 1 , nvmx(iv)
              ivx = ivmx(iv,kv)
              if (.not.vxtup(ivx)) then
                do 114 jn = istart(ib+1) , istop(ib+1)
                  if (list(1,jn) .eq. ivx) then
                    if (list(3,jn) .lt. itndxtup) then
                      hang = .true.
                      ithang = list(3,jn)-itstart(ib)
                      go to 115
                    end if
                    go to 113
                  end if
114             continue
              end if
113         continue
          end if
115       continue
          if (allxtup .and. .not.hang) then
            do 108 iv = 1 , nv
            do 108 kv = 1 , nvmx(iv)
              ivx = ivmx(iv,kv)
              if (ntupv(ivx).gt.0) xtupfac(ivx) =fxtup*maxtup/ntupv(ivx)
108         continue
          else 
c
c  Must deal with simultaneous non-xtuplets 
c
            if (.not.hang) then
              elother = 0.
              jb1 = ib
            else
              elother = feon(float(ithang))
              numblx = numblx+1
              jb1 = ib+1
            end if
            do 103 jb = jb1 , nb
              nspb = (list(3,istop(jb))-list(3,istart(jb)))/nspace(jb)+1
              elother = elother+nspb*feon(float(nspace(jb)))
              if (itndxtup .le. list(3,istop(jb))+nspace(jb)) go to 104
c
c  If here, xtup spans more than one block, including possible hanger.  
c
              numblx = numblx+1
103         continue
104         continue
            if (elxtup .gt. elother) then
c
c  Xtup dominates length.  Stretch other stuff.  
c
              fother = elxtup/elother
            else
c
c  Other stuff dominates length, stretch xtup
c
              fother = 1.
              fxtup = fxtup*elother/elxtup
            end if
            do 105 iv = 1 , nv
            do 105 kv = 1 , nvmx(iv)
              ivx = ivmx(iv,kv)
              if (vxtup(ivx)) then
                xtupfac(ivx) = fxtup*maxtup/ntupv(ivx)
              else
                xtupfac(ivx) = fother
              end if
105         continue
          end if
        else if (numblx .gt. 1) then
c
c  In a block with continuation--but not start--of xtup. Use left-over fother
c
          do 106 iv = 1 , nv
          do 106 kv = 1 , nvmx(iv)
            ivx = ivmx(iv,kv)
            if (vxtup(ivx)) then
              xtupfac(ivx) = 1.
            else
              xtupfac(ivx) = fother
            end if
106       continue
          numblx = numblx-1
        else 
c
c  In a block unaffected by xtuplets
c
          do 107 iv = 1 , nv
          do 107 kv = 1 , nvmx(iv)
            ivx = ivmx(iv,kv)
            vxtup(ivx) = .false.
            xtupfac(ivx) = 1.
107       continue
          numblx = 0
        end if
c
c  Done setting up xtuplet stuff.  Run thru whole block, flag accidentals etc
c  that are too close.  just 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
        inarp = .false.
        itrpt = -1
        itsig = -1
111     in = in+1
        if (in .gt. istop(ib)) go to 112
        ip = list(2,in)
        ivx = list(1,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  Remember, rpts & internal sigs can only come at start of (internal) block
c
        isacc = accq(ivx,ip) .ne. 'x'
        isaccs = isacc .or. btest(iornq(ivx,ip),0)
        isarp = btest(iornq(ivx,ip),27)
        if (btest(ipl(ivx,ip),10)) then
c
c  Check chord notes for accidentals and arpeggios.  
c
          call chkarp(found1,ncrd,icrdat,ivx,ip,isaccs,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 = list(3,in)
        issig  = btest(ipl(ivx,ip),28) 
        if (ivx.eq.1 .and. issig) itsig = list(3,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
          nd = nodur(ivx,ip-1)
          isbstrt = blkstart(list,in,itstart(ib),
     *                         nodur(list(1,in-1),list(2,in-1))) 
          isgaft = btest(ipl(ivx,ip-1),29) .or. btest(ipl(ivx,ip-1),31)
          isgrace = isgrace .or. isgaft
        end if
c
c  Bypass if non-grace, not 1st in bar, & prev. note uses > 1 noteskip
c
        if (ip.gt.1 .and. .not.isgrace) then
c
c  Prior note can't end Xtup, since not last note in voice in block.
c
          nsp = nspace(ib)
          if (isbstrt) nsp = nspace(ib-1)
          if (nd .gt. nsp) then
            if (isaccs .and. bacfac.lt.1.e5) 
     *             accq(ivx,ip) = upcaseq(accq(ivx,ip))
            go to 99
          end if
        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. nd.gt.0 .and. nd.lt.16 
        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
            else if (ip-1.le.ibm2(ivx,ibmchk)) 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
        isdot = ip.gt.1 .and. .not.vxtup(ivx) 
        if (isdot) isdot = 2**log2(max(1,nd)).ne.nd
c
c  Next line negates isdot if dotted item is xtuplet.
c
        if (isdot) isdot = ip.eq.2 .or. nodur(ivx,ip-2).gt.0
        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)) go to 111
c
c  Here is an accid,grace,clef,flag,dot,udsp,uxsp,arpeg. May need space. 
c
        pts = wheadpt
        if (isgrace) then
          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.
c  spgr = total space needed (w/o main acc). NB apt=wheadpt, don't get confused.
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
          else
            wgr = nng(ig)*emgfac
            do 126 ing = 2 , nng(ig)
              if (accgq(ngstrt(ig)-1+ing) .ne. 'x') wgr = wgr+acgfac
126         continue 
          end if
          ptgr(ig) = wgr*wheadpt
          spgr = ptgr(ig)+xb4fac*wheadpt    
          if (isaccs) ptgr(ig) = ptgr(ig) + accfac*wheadpt
          if (accgq(ngstrt(ig)) .ne. 'x') spgr = spgr+wheadpt*agc1fac
          pts = pts+spgr
        end if
        if (iscln) then
          pts = pts+clefac*wheadpt
c
c  How far to backspace when printing the clef
c
          ptclef(ivx) = 0.
          if (isaccs) ptclef(ivx) = ptclef(ivx)+accfac*wheadpt
          if (isgrace) ptclef(ivx) = ptclef(ivx)+spgr
c     print*,'+CLEF, ptclef, pts->',ptclef(ivx),pts
        end if
        if (isrshft) then
          pts = pts+rtshfac*wheadpt
        else if (isflag) then
          pts = pts+flagfac*wheadpt
c     print*,'+FLAG, pts->',pts
        else if (isdot) then
          pts = pts+dotfac*wheadpt
c     print*,'+DOT, pts->',pts
        end if
        if (list(3,in) .eq. itrpt) then
c
c  Repeat, need a little extra space 
c
          pts = pts+dotsfac*wheadpt
c     print*,'ITRPT, pts->',pts
        end if
        if (isarp) then
          pts = pts+arpfac*wheadpt
c     print*,'Due to isarp, pts, arpfac:',pts,arpfac
        end if 
        pts = pts+xspfac*wheadpt
c     print*,'FINISH, xspfac,pts->',xspfac,pts
c
c  Get available space in elemskips (esk)
c
        esk = 0.
        isxtup = .false.
        isfirst = .false.
c     print*,'numblx,isbstrt:',numblx,isbstrt
c       if (numblx.eq.0 .or. isbstrt) then
        if (numblx.eq.0 .or. isbstrt .or. ip.eq.1) then
c
c  No influence of xtuplets (unless 1st note in non-1st blk & prev blk is xtup)  
c
          isfirst = ip.eq.1 .or. list(3,in).eq.itrpt .or.
     *        list(3,in) .eq. itsig
          if (isfirst) then
c
c  At start of bar or after repeat sign or new signature
c
            if (list(3,in) .eq. itsig) then
              esk = 0.
            else
              esk = fbar
            end if
c     print*,'Start of bar or after repeat, ibar,esk:',ibar,esk
          else if (isbstrt) then
c
c  Not 1st note of bar; first note of block
c
c     print*,'Not 1st of bar; 1st of block; xtupb4,ip,nodur(ip-2): '
c    *,xtupb4,ip,nodur(ivx,ip-2)
            if (xtupb4) then
c             if (ip.gt.2 .and. nodur(ivx,ip-2).eq.0) then
cc
cc  Xtup in prev block in this voice
c  Xtup in prev block in some voice
cc
                esk = feon(float(nspace(ib-1)))*xtfold(ivx)
c             else
c               continue
c
cc  Xtup in prev block but not in this voice; use left-over params from prev. blk
cc  Fill in later
c
c             end if
            else
c
c  Not at start of bar; 1st in blk, no xtup. 
c  Note in prior block uses only one noteskip
c
              esk = feon(float(nspace(ib-1)))
c     print*,'Not at start of bar, 1st in blk, no xtup, esk:',esk
            end if
          else
c
c  No xtup, not 1st in bar, not 1st in blk
c  Note uses only one noteskip
c
            esk = feon(float(nspace(ib)))
c     print*,'No xtup, not 1st in bar, not 1st in blk, esk:',esk
          end if
        else if (inxtup .and. in.gt.istart(ib)) then
          if (vxtup(ivx)) then 
c
c  Check for interference in xtuplet.
c
            esk = elxtup/ntupv(ivx)
            isxtup = .true.
c     print*,'In xtup, esk:',esk
          else
            esk = 100. 
          end if
        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.  But if it was xtup. don't need to call eskb4.  
c
          if ((ip.le.2 .or. nodur(ivx,ip-2).gt.0) .and. 
     *                                list(3,in).ne.itsig) 
     *          call eskb4(ip,ivx,in,ib,nspace,itstart,fbar,itrpt,esk)
        end if
c
c  Done getting available elemskips.  Check if we got anything:
c
        if (esk .lt. .0001) then
c         print*,'BOOGERS!! esk not set'
c         go to 111
        end if 
        if (isfirst) pts = pts-wheadpt
c     print*,'isfirst,pts:',isfirst,pts
        ptbneed = pts
c     print*,'ptbneed: ',ptbneed
        if (isaccs) ptbneed = ptbneed+wheadpt*bacfac
c     print*,'poenom*esk,ptbneed=>',poenom*esk,ptbneed
        if (poenom*esk .gt. ptbneed) then
          if (isacc) accq(ivx,ip) = upcaseq(accq(ivx,ip))
c     print*,'BIG GAP, UPCASEQ, pts,esk:',ptbneed,esk
          go to 99
        end if
        ptsneed = pts
        if (isaccs) ptsneed = ptsneed+accfac*wheadpt
c     print*,'ptsneed, ptsavail:',ptsneed,poenom*esk
        if (poenom*esk .lt. ptsneed) then
          if (.not.isxtup) then
            call addask(list(3,in),ptsneed,esk,fixednew,scaldold,
     *                  0,.false.)
c     print*,'AddasK,pts,esk:',ptsneed,esk
c     print*
          else
            call addasx(ip,ivx,ptsneed,esk,fixednew,scaldold,.false.)
c     print*,'AddasX,pts,esk:',ptsneed,esk
c     print*
            if (numblx.gt.1) xtupfac(ivx) = xtupfac(ivx)*
     *             (1-((apt+wheadpt)/poenom-esk)/elxtup)
          end if
        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(list(3,in),ptsneed,zero,
     *                fixednew,scaldold,itglp1,.true.)
        else if (btest(irest(ivx,ip),21)) then
c                                                          
c  User-defined xtup space.  Warning, "zero" may change value in addask!  
c
          call addasx(ip,ivx,ptsneed,esk,fixednew,scaldold,.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.  Check for internal repeat or sig change.
c
        if (ib.gt.1 .and. list(1,istart(ib)).eq.1) then
          iirpt = iand(islur(1,list(2,istart(ib))),67109216)
          if (iirpt .gt. 0) then
c
c Internal repeat
c
            write(11,'(a)')sq//'advance'//sq//'barno-1%'
            if (iirpt .eq. 96) then
              write(11,'(a)')sq//'leftrightrepeat'
              fixednew = fixednew+lrrptfac*wheadpt
            else if (btest(iirpt,5)) then
              write(11,'(a)')sq//'leftrepeat'
              fixednew = fixednew+rptfac*wheadpt
            else if (btest(iirpt,6)) then
              write(11,'(a)')sq//'rightrepeat'
              fixednew = fixednew+rptfac*wheadpt
            else if (btest(iirpt,8)) then
              write(11,'(a)')sq//'doublebar'
            else
              print*,'Unexpected mid-bar repeat command R*'
              stop 1
            end if
            scaldold = scaldold-fbar
          end if
          if (btest(ipl(1,list(2,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
            write(11,'(a)')notexq(1:lnote)//char(48+abs(isig))//'}%'
            write(11,'(a)')sq//'zchangecontext'//sq//'addspace{-.5'
     *            //sq//'afterruleskip}%'
            lnote = 0
          end if
        end if
        xtupb4 = .false.
        flgndb = .false.
        do 11 iv = 1 , nv
        do 11 kv = 1 , nvmx(iv)
          ivx = ivmx(iv,kv)
          figcheck = figbass .and. ivx.eq.1 .and. nfigs.gt.0
          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 = lc(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 = lc(lowerq,80)
            call addstr(sq//'zcharnote{-6}{'//
     *        sq//'tempo'//sq//'kern-10pt '//
     *        lowerq(1:lclow)//'}',33+lclow,soutq,lsout)
            lower=.false.
          end if
          if (numblx.gt.0) then
            if (abs(xtupfac(ivx)-1.).gt..005) then
              notexq = sq//'multnoteskip{    '  
              if (xtupfac(ivx) .ge. 0.995) then
                write(notexq(15:18),'(f4.2)')xtupfac(ivx)
              else
                write(notexq(15:18),'(a1,f3.2)')'0',xtupfac(ivx)
              end if
              call addstr(notexq(1:18)//'}',19,soutq,lsout)
            end if
            if (inxtup .and. hang .and. .not.vxtup(ivx))
     *              call addstr(sq//'sk',3,soutq,lsout)
          end if
          itnow = itstart(ib)
          nofirst = .true.
          do 10 jn = istart(ib), istop(ib)
            if (list(1,jn) .ne. ivx) go to 10
            ip = list(2,jn)
            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 (figcheck .and. itfig(ifig).lt.itnow) then
c
c  Bypassed figure location. Backup, place fig, return.
c
              offnsk = float(itnow-itfig(ifig))/nspace(ib)
              call putfig(ifig,offnsk,figcheck,soutq,lsout)
              go to 12
            end if
c
c  Put in \sk if needed
c
            if (list(3,jn) .gt. itnow) then   
              call addstr(sq//'sk',3,soutq,lsout)
              itnow = itnow+nspace(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. 
     *            itnow.ge.itask(iaskb(ivx))) then
              if (itask(iaskb(ivx)) .ge. itstart(ib)) 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 itask's in earlier blocks (due to void voice)
c
              iaskb(ivx) = iaskb(ivx)+1
              go to 21
            end if
22          if (iasxb.le.nasxb .and. ip.eq.ipasx(iasxb) 
     *          .and. ivx.eq.ivasx(iasxb)) then
              call addstr(sq//'asx     ',9,soutq,lsout)
              nasxsys = nasxsys+1
              wasxsys(nasxsys) = wasx(iasxb)
              elasxsys(nasxsys) = elasx(iasxb)
              iasxb = iasxb+1
            end if
            if (figcheck .and. itfig(ifig).eq.itnow) then
c
c  Figure on a note.  NB: later special check for late figs.
c
              call putfig(ifig,0.,figcheck,soutq,lsout)
            end if
c
c  Check for new clef here.
c
            if (isclef .and. btest(islur(ivx,ip),11)) then
c     print*,'At clef insertion, ptclef:',ptclef(iv)
              if (ptclef(iv) .gt. 0.) then
                notexq = sq//'off{-'
                if (ptclef(iv) .lt. 9.95) then
                  write(notexq(7:9),'(f3.1)')ptclef(iv)
                  lnote = 9
                else
                  write(notexq(7:10),'(f4.1)')ptclef(iv)
                  lnote = 10
                end if
                notexq = notexq(1:lnote)//'pt}'
                lnote = lnote+3
                call addstr(notexq,lnote,soutq,lsout)
c     print*,'Just added: ',notexq(1:lnote)
              end if
              call clefsym(islur(iv,ip),notexq,lnote,nclef)
              call addstr(notexq,lnote,soutq,lsout)
              if (ptclef(iv) .gt. 0.) then
                notexq = sq//'off{'
                if (ptclef(iv) .lt. 9.95) then
                  write(notexq(6:8),'(f3.1)')ptclef(iv)
                  lnote = 8
                else
                  write(notexq(6:9),'(f4.1)')ptclef(iv)
                  lnote = 9
                end if
                notexq = notexq(1:lnote)//'pt}'
                lnote = lnote+3
                call addstr(notexq,lnote,soutq,lsout)
c     print*,'Just added: ',notexq(1:lnote)
              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'
              stop
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
                write(11,'(a)')soutq(1:lsout)//'%'
                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
              call putarp(itnow,iv,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) then
              if (.not.btest(irest(ivx,ip),24)) then
c
c  Not a jump start
c
                call beamstrt(notexq,lnote,nornb,ihornb)
c
c  Shift beam start if necessary
c
                if (btest(ipl(ivx,ip),8)) 
     *           call addstr(sq//'loff{',6,soutq,lsout)
                if (btest(ipl(ivx,ip),9)) 
     *           call addstr(sq//'roff{',6,soutq,lsout)
                call addstr(notexq,lnote,soutq,lsout)
                if (btest(ipl(ivx,ip),8) .or. 
     *            btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout)
              end if
              beamon(ivx) = .true.
              bspend = .true.
            end if
c
c  Setup for chords and possible slurs in chords
c
            if (btest(ipl(ivx,ip),10)) call precrd(ivx,ip,nolev(ivx,ip))
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)) 
     *           call doslur(nolev(ivx,ip),isdat1,isdat2,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) 
              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),
     *                 accq(ivx,ip),ig,ipl(ivx,iphold),.false.)
                  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
                    call endslur(stemup,.not.upg(ig),nolev(ivx,ip),0,
     *                 ndxslur,0,ncmid(iv,ip),soutq,lsout)
                  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
                ndxslur = log2(511-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
                notexq = sq//'islur'//slurudq//char(48+ndxslur)
     *              //noteq(1:lnoten)
                call addstr(notexq,8+lnoten,soutq,lsout) 
                call setbits(ipl(ivx,ip),4,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  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
              if (.not. vxtup(ivx)) then
                nodu = nodur(ivx,ip)
              else if (mult(ivx,ip) .lt. 0) then
                nodu = 32
              else
                nodu = 16
              end if
              call docrd(ivx,ip,nodu,ncmid(iv,ip),iv,itnow,soutq,lsout,
     *                   ulq,ibmcnt(ivx),islur(ivx,ip),nvmx(iv),nv,
     *                   beamon(ivx),nolev(ivx,ip),ihornb,nornb,stemlen)
            end if
c
c  Check for main-note ornaments. ')' on dotted notes go in with note, not here.
c  Bits 0-13: (stmgx+Tupf._) ; 14: Down fermata, was F   
c  15: Trill w/o "tr", was U , 16-18 edit. accid., 19-21 TBD
c
            isacc = iand(iornq(ivx,ip),4194287) .gt. 0
c
c  isacc=.true. if any ornament except segno
c
            if (btest(iornq(ivx,ip),13) .and. nodur(ivx,ip).gt.0) then
c
c  If ).  is only ornament, bypass.  If with others, temporarirly zero the bit.
c
              if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then
                if (iand(iornq(ivx,ip),516079) .eq. 0) then
c
c  ). is the only non-segno ornament
c
                  isacc = .false.
                else
c
c  There are other ornaments in addition
c
                  rpndot = .true.
                  iornq(ivx,ip) = ibclr(iornq(ivx,ip),13)
                end if
              end if
            end if
            if (isacc .and. .not.cwrferm(ivx)) then
c
c  Check for centered whole-bar rest with fermata (bits 10 or 14).
c
              if (iand(iornq(ivx,ip),17408).gt.0 
     *                               .and. btest(irest(ivx,ip),0) .and. 
     *             nodur(ivx,ip).eq.lenbar .and.
     *             .not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)) then
                cwrferm(ivx) = .true.
                go to 30
              end if
              call putorn(iornq(ivx,ip),nolev(ivx,ip),nolev(ivx,ip),
     *             nodur(ivx,ip),nornb,ulq,ibmcnt(ivx),ivx,ncmid(iv,ip),
     *             islur(ivx,ip),nvmx(iv),nv,ihornb,stemlen,
     *             notexq,lnote,ip,islhgt,beamon(ivx),
     *             btest(ipl(ivx,ip),10))
              call addstr(notexq,lnote,soutq,lsout)
            end if
            if (rpndot) then
              iornq(ivx,ip) = ibset(iornq(ivx,ip),13)
              rpndot = .false.
            end if
30          continue
c
c  Accidentals
c  May have 'X' on main note if chord note has accid.  Was set in \ask-checks.
c  
            if (index('xX',accq(ivx,ip)) .eq. 0) then
              if (iand(ipl(ivx,ip),768) .gt. 0) then
c
c  Main note shifted, so shift accid.  Remeber to terminate when accid is done.
c
                if (btest(ipl(ivx,ip),8)) then
                  notexq = sq//'loff{'//sq
                else
                  notexq = sq//'roff{'//sq
                end if
                lnote = 7
              else
                notexq = sq
                lnote = 1
              end if
              if (ichar(accq(ivx,ip)) .le. 90) then 
                notexq = notexq(1:lnote)//'big'
                lnote = lnote+3
              end if
              call accsym(accq(ivx,ip),acsymq,lacc)
              notexq = notexq(1:lnote)//acsymq(1:lacc)
              lnote = lnote+lacc
              call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
              if (lnoten .eq. 1) call addblank(noteq,lnoten)
              notexq = notexq(1:lnote)//noteq(1:lnoten)
              lnote = lnote+lnoten
              if (iand(ipl(ivx,ip),768) .gt. 0) then
c
c  Terminate shift
c
                notexq = notexq(1:lnote)//'}' 
                lnote = lnote+1
              end if
              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
            if (lowdot .and. nvmx(iv).eq.2 .and. ivx.le.nv) 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)
                end if
              end if
            end if
c
c  Check for dotted notes with moved dots
c
            if (btest(irest(ivx,ip),19)) then
              ndotmv(ivx) = ndotmv(ivx)+1 
              call dotmov(updot(ivx,ndotmv(ivx)),rtdot(ivx,ndotmv(ivx)),
     *           soutq,lsout)
            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  
              call beamn1(notexq,lnote)
              bspend = .false.
c
c  Is a beam ending?
c
            else if (numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx) 
     *           .and. ibm2(ivx,ibmcnt(ivx)) .eq. ip) then
              if (bspend) then
c
c  Must be a single-note ending of a jump-beam
c
                isbjmp = .true.
                bspend = .false. 
              end if
              call beamend(notexq,lnote)
c
c  If this is an xtuplet that stretches >1 block, must backspace.
c
              if (numblx .gt. 1) then
                call addstr(notexq,lnote,soutq,lsout)
                notexq = sq//'off{-  '
                if (ntupv(ivx) .le. 9) then
                  write(notexq(7:7),'(i1)')ntupv(ivx)
                  notexq = notexq(1:7)//sq//'noteskip}'
                  lnote = 17
                else
                  write(notexq(7:8),'(i2)')ntupv(ivx)
                  notexq = notexq(1:8)//sq//'noteskip}'
                  lnote = 18
                end if
              end if
              nornb(ivx) = 0
              ibmcnt(ivx) = ibmcnt(ivx)+1
              beamon(ivx) = .false.
c
c  Or if we're in the middle of a beam
c
            else if (numbms(ivx).gt.0 .and. beamon(ivx)) then
              call beamid(notexq,lnote)
c
c      Or whole-bar rest            
c
            else if (btest(irest(ivx,ip),0) 
     *               .and. nodur(ivx,ip).eq.lenbar
     *     .and..not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)
     *     .and..not.btest(islur(ivx,ip),29)) then
c
c  Rule out pickup bar, blank rests.  Remember that islur b19=> rp
c
              cwrest(ivx) = .true.
              call notex(cwrq,lcwr)
              itnow = itnow+lenbar
              go to 10
            else 
c
c  Write a separate note
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)
            end if
            if (btest(ipl(ivx,ip),9)) 
     *           call addstr(sq//'roff{',6,soutq,lsout)
            call addstr(notexq,lnote,soutq,lsout)
            if (btest(ipl(ivx,ip),8) .or. 
     *          btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout)
c
c  Terminate user-defined offsets.  Fix format
c
            if (btest(irest(ivx,ip),15) .or. btest(irest(ivx,ip),17)) 
     *          call putshft(ivx,.false.,soutq,lsout)
c
c  Deal with After- and Way-after-graces.  First, if end of bar, compute space 
c    needed since it wasn't done during general ask-checks. If extra space is
c    rq'd, convert GW to GA.  Therefore GW at end of bar never needs extra sp.
c    But will still need to add extra space as hardspace.
c
            if (ip.eq.nn(ivx) .and. (btest(ipl(ivx,ip),31).or.
     *                               btest(ipl(ivx,ip),29))) then
              do 77 ig = 1 , ngrace
                if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 78
77            continue
              print*,'Problem finding grace index at "do 77"'
              stop 1
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 = list(3,iand(255,ipl(ivx,ip)))
                else
                  itleft = itstart(ib)
                end if
                if (iib .lt. nb) then
                  itright = itstart(iib+1)
                else
                  itright = lenbar
                end if
                esk = esk+feon(float(nspace(ib)))*
     *                          (itright-itleft)/nspace(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 (accgq(ngstrt(ig)-1+ing) .ne. 'x') wgr = wgr+acgfac
41              continue 
              end if
              ptgr(ig) = wgr*wheadpt
c             ptsneed = (wgr+xb4fac)*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),
     *            accq(ivx,ip),ig,ipl(ivx,ip),.false.)
            if (.not.vxtup(ivx) .or. nodur(ivx,ip).gt.0) 
     *            itnow = itnow+nspace(ib)
10        continue              
c
c  Have finished last note in this voice and block
c
          itendb = list(3,istop(ib))+nspace(ib)
17        if (figcheck .and. itfig(ifig).lt.itendb) then
c
c  There's at least one figure left. offnsk could be <0
c
            offnsk = float(itnow-itfig(ifig))/nspace(ib)
            call putfig(ifig,offnsk,figcheck,soutq,lsout)
            go to 17
          end if
c
c  Check for flag, dot, or upstem on last note of bar. 
c
          if (ib .eq. nb) then
            ip = list(2,iand(255,ipl(ivx,nn(ivx))))
            flgndv(ivx) = 0.
            if ( .not.vxtup(ivx) .and. 
     *           nodur(ivx,ip).eq.nspace(ib)) then
              if (nspace(ib).lt.16 ) then
c
c  Non-xtup, in last nspace, 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. 2**log2(nodur(ivx,ip)).ne.nodur(ivx,ip)) then
c
c  Upstem non-rest, or dotted  
c
                  if (numbms(ivx).gt.0 .and. ip.eq.ibm2(ivx,numbms(ivx))
     *              .and. 2**log2(nodur(ivx,ip)).eq.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, non-xtup, nonflagged (no beam) only worry dot or up
c    
                if (2**log2(nodur(ivx,ip)).ne.nodur(ivx,ip)) then
c
c  Dotted
c
                  flgndv(ivx) = flagfac
                else if (nodur(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.
          end if
          xtupb4 = xtupb4 .or. vxtup(ivx)
          vxtup(ivx) = .false.
          xtfold(ivx) = xtupfac(ivx)
11      continue
c
c  Close out the notes group
c
        call addstr(sq//'en',3,soutq,lsout) 
        if (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)),
     *      accq(ivx,nn(ivx)),ig,ipl(ivx,nn(ivx)),.true.)
        end if
75    continue  
      if (isgrace) then
        call addstr(sq//'en%',4,soutq,lsout)
        if (lsout .gt. 0) write(11,'(a)')soutq(1:lsout)
      end if
c
c  Write stuff for whole bar rests if needed.  Assuming no multi-voice staves
c
      lsout = 0
      do 60 iv = 1 , nv
        if (lsout .gt. 0) then
c
c  Have already inserted at least one rest.  Append sepsymq
c
          soutq = soutq(1:lsout)//sepsymq(iv-1)
          lsout = lsout+1
        end if
        if (cwrest(iv)) then
c???        if (cwrest(ivx)) then
          if (lsout .eq. 0) then
c
c  In case it's a liftpause, must surround w/ brackets as arg of centerbar
c
            if (ibar .ne. ibarmbr) then
              if (cwrq(2:5) .eq. 'lift') then
                notexq = '{'//cwrq(1:lcwr)//'}'
                lcwr = lcwr+2
                cwrq = notexq(1:lcwr)
              else if (cwrferm(iv)) then 
c
c  Fermata on centered rest, use brackets
c
                notexq = '{'//sq//'fermataup7'//cwrq(1:lcwr)//'}'
                lcwr = lcwr+13
                cwrq = notexq(1:lcwr)
                cwrferm(iv) = .false.
              end if
              write(11,'(a)')sq//'def'//sq//
     *              'wbrest{'//sq//'centerbar'//cwrq(1:lcwr)//'}%'
            end if
c
c  This is the first voice with rest.  Set up the string.
c
            soutq = sq//'def'//sq//'atnextbar{'//sq//'znotes'
            lsout = 22
            do 62 jv = 2 , iv
              soutq = soutq(1:lsout)//sepsymq(jv-1)
              lsout = lsout+1
62          continue      
          end if
          if (ibar .ne. ibarmbr) then
c
c  Single-bar rest
c
            soutq = soutq(1:lsout)//sq//'wbrest'
            lsout = lsout+7
          else
c
c  Multibar rest
c
            soutq = soutq(1:lsout)//sq//'mbrest{'
            lsout = lsout+8
            ndig = int(alog10(mbrest+.01))+1
            write(soutq(lsout+1:lsout+2),'(i'//char(48+ndig)//')')mbrest
            lsout = lsout+ndig
            soutq = soutq(1:lsout)//'}{'
            lsout = lsout+2
            mtrspc = .5+xb4mbr
            xb4mbr = 0.
            if (mtrspc .eq. 0) then
              ndig = 1
            else
              ndig = int(alog10(mtrspc+.01))+1
            end if
            write(soutq(lsout+1:lsout+2),'(i'//char(48+ndig)//')')mtrspc
            lsout = lsout+ndig
            soutq = soutq(1:lsout)//'}0'
            lsout = lsout+2
          end if  
        end if
60    continue
      if (lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//sq//'en}%'           
      if (ibar .eq. ibarmbr) then
        ndig = int(alog10(mbrest-1+.01))+1
        write(11,'(a14,i'//char(48+ndig)//',a1)')sq//'advance'
     *      //sq//'barno',mbrest-1,'%'
      end if
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)
          lastnodur(ivx) = nodur(ivx,nn(iv))
63      continue
      end if
      return
      end
      subroutine make1bar(ibmrep,nbxtup,itglp1,itstart,cwrest,
     *    nindex,istop,n1xtup,numbms,istart,nxtup,lbxtup)
      parameter (nm=7)
      common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      character*6 figq
      character*1 accq,ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,isfig,bar1syst
      common /comfig/ itfig(74),figq(74),nfigs
      common /combeam/ ibmtyp
      common /comask/ bar1syst,fixednew,scaldold,apt,abigpt,
     *                wheadpt,fbar,poenom
      common /comas1/ naskb,itask(20),wask(20),elask(20),iasxb,
     *                nasxb,ipasx(20),ivasx(20),wasx(20),elasx(20)
      common /comas2/ nasksys,wasksys(400),elasksys(400),
     *                nasxsys,wasxsys(100),elasxsys(100)
      common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
      common /comfb/ nfb(nm),it1fb(nm,20),it2fb(nm,20),ulfbq(nm,20),ifb
      common /comsln/ is1n1,is2n1,irzbnd,isnx
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),aftshft,
     *                nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
     *                noffseg,ngrace,nvolt,ivlit(36),iplit(36),nlit,
     *                lenlit(36),multg(37),upg(37),slurg(37),slashg(37),
     *                accgq(74),voltxtq(6),litq(36)
      logical upg,slurg,slashg,rpndot
      character*128 litq
      common /comcc/ ncc(nm),itcc(nm,10),ncmidcc(nm,10),
     *               ndotmv(nm),updot(nm,20),rtdot(nm,20)
      integer it(nm),cnn(nm),istart(20),istop(20),itstart(20),
     *        nindex(20),numbms(nm),mapfb(4),it1xtup(20),n1xtup(20),
     *        lbxtup(20)
      character*1 ulfbq,accgq
      character*79 inameq
      character*10 voltxtq
      common /comoct/ noctup
      character*80 headrq,lowerq
      common /comnsp/ nspace(20),nb,xtfold(nm),xtupb4,lastnodur(nm),
     *    flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
      logical lower,cwrest(nm),inxtup,vxtup,xtupb4,flgndb,btest,upslur,
     *        infbm,cwrferm(nm),lowdot
      common /comxtup/ xtupfac(nm),n2xtup(20),ixtup,vxtup(nm),inxtup,
     *                 ntupv(nm),nolev1,islope,xelsk(24),eloff
      common /comstart/ nstartq,lstart(15),facmtr
      character*6 nstartq(15)
      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 or apt)
c  In 1.04, moved to block data subprogram
c
c      common /comslur/ listslur,ndxslur(nm,2),upslur(nm,2)
      common /comslur/ listslur,upslur(nm,2),ndxslur
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,inameq(nm),idsig
      common /comudsp/udsp(25),itudsp(25),nudsp,udoff(nm,20),nudoff(nm),
     *                 uxsp(25),ivuxsp(25),ipuxsp(25),nuxsp
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
c
c  Time from start of gulp to end of bar, used with forced beams
c
      itglp2 = lenb0+ibar*lenb1 
      if (lenb0 .gt. 0) itglp2 = itglp2-lenb1 
      itglp1 = itglp2-lenbar
c
c  For now, assume no whole bar rests if multi-voices per staff
c
      do 1 iv = 1 , nv
      do 1 kv = 1 , nvmx(iv)
        ivx = ivmx(iv,kv)
        if (ivx .le. nv) cwrest(iv) = .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
      rpndot = .false.
      inxtup = .false.
      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
2       list(1,in) = ivx
        list(2,in) = cnn(ivx)
        list(3,in) = 0
        it(ivx) = nodur(ivx,cnn(ivx))
c
c  Note that it(ivx) is to END of note in voice, but it1xtup is start time.
c
        if (nodur(ivx,list(2,in)) .eq. 0) then
          if (.not.inxtup) then
c
c  First note of xtuplet.
c
            nxtup = nxtup+1
            inxtup = .true.
            it1xtup(nxtup) = 0
            n1xtup(nxtup) = in
c
c  If not in explict forced beam, put xtup in one, & 
c    put in order with all fb's in gulp.
c
            infbm = .false.
            if (nfb(ivx).gt.0) then
              do 70 ifb = 1 , nfb(ivx)
                if (it1fb(ivx,ifb) .eq. itglp1) then
                  infbm = .true.
                  go to 71
                end if
70            continue
            end if
71          continue 
c    *      call addfb(nfb,ivx,it1xtup(nxtup)+itglp1,
            if (.not.infbm) call addfb(nfb,ivx,it1xtup(nxtup)+
     *            itglp1,it1fb,it2fb,ulfbq,ifbadd)
          end if
c
c  To keep all notes of xtup together, get another note from this voice 
c
          in = in+1
          cnn(ivx) = cnn(ivx)+1
          go to 2
        else if (inxtup) then
c
c  End the xtuplet
c
          inxtup = .false.
          n2xtup(nxtup) = in
          if (.not. infbm) it2fb(ivx,ifbadd) = 
     *      it1xtup(nxtup)+nodur(ivx,cnn(ivx))+itglp1
        end if
        if (it(ivx) .eq. lenbar) it(ivx) = 1000
        in = in+1
4     continue
c
c  Build the list:  Manual loop starting at 5
c
5     continue
c
c  Determine which voice comes next from end of notes done so far.
c  itmin is the earliest ending time of notes done so far
c
      itmin = 1000
      do 6 iiv = 1 , nv
      do 6 kv = 1 , nvmx(iiv)
        iivx = ivmx(iiv,kv)
        itminn = min(itmin,it(iivx))
        if(itminn .lt. itmin) then
          itmin = itminn
          ivx = iivx
        end if
6     continue
      if (itmin .eq. 1000) go to 7
      list(1,in) = ivx
      cnn(ivx) = cnn(ivx)+1
      list(2,in) = cnn(ivx) 
      list(3,in) = itmin
c
c  Check if this voice is done
c           
      if (cnn(ivx) .eq. nn(ivx)) then
        it(ivx) = 1000
      else
        it(ivx) = it(ivx)+nodur(ivx,cnn(ivx)) 
      end if
c
c  Flag xtups
c
      if (nodur(ivx,cnn(ivx)) .eq. 0) then
        if (.not.inxtup) then
c
c  First note of xtup, not at start of bar.
c
          nxtup = nxtup+1
          inxtup = .true.
          n1xtup(nxtup) = in
          it1xtup(nxtup) = it(ivx)
c
c  (Note: can't be on last note in voice, so it(ivx) <> 1000)
c  Put xtuplet in a forced beam if not already in forced beam
c
          infbm = .false.
          if (nfb(ivx).gt.0) then
            do 72 ifb = 1 , nfb(ivx)
              if (it1fb(ivx,ifb) .le. itglp1+it(ivx) .and.
     *            it2fb(ivx,ifb) .gt. itglp1+it(ivx)) then
                infbm = .true.
                go to 73
              end if
72          continue
          end if
73        continue 
c         call addfb(nfb,ivx,it1xtup(nxtup)+itglp1,
          if (.not.infbm) call addfb(nfb,ivx,it1xtup(nxtup)
     *        +itglp1,it1fb,it2fb,ulfbq,ifbadd)
        end if
      else if (inxtup) then
        inxtup = .false.
        n2xtup(nxtup) = in
c       it2fb(ivx,ifbadd) = it1xtup(nxtup)+nodur(ivx,cnn(ivx))+itglp2
c    *                         -lenbar
        if (.not.infbm) it2fb(ivx,ifbadd) = it1xtup(nxtup)
     *           +nodur(ivx,cnn(ivx))+itglp1
      end if
      in = in+1
      go to 5
7     continue
      ntot = in-1
      do 8 in = 1 , ntot-1
        list(4,in) = list(3,in+1)-list(3,in)
8     continue
      list(4,ntot) = nodur(list(1,ntot),list(2,ntot))
c
c  Done w/ list. A kluged up loop for parsing into note blocks:
c
      ib = 1 
      istart(1) = 1
      nspace(1) = 0
      in = 1 
c
c  A loop to set nspace(ib) and istop(ib)
c
9     continue
        
        ivx = list(1,min(in+1,ntot))
        ip = list(2,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) )) then
c
c  Bar end, segno, int. rpt or sig change, clef; flow out of if-loop and into 
c  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 
          if (btest(isl,15)) then
            do 50 iin = in , 1 , -1
              if (list(4,iin) .gt. 0) then
                in = iin
                islur(ivx,ip) = ibclr(islur(ivx,ip),15)
                islur(list(1,in+1),list(2,in+1)) = 
     *             ibset(islur(list(1,in+1),list(2,in+1)),15)
                go to 51
              end if
50          continue
51          continue
          end if
          if (nspace(ib) .eq. 0) nspace(ib)=list(4,in)
          istop(ib) = in
          continue
        else if (nspace(ib) .eq. 0) then
c
c  Nspace hasn't been set yet, so tentatively set:
c
          nspace(ib) = list(4,in)
          if (nspace(ib) .eq. 0) then
            in=in+1
          else
            istop(ib) = in
          end if
          go to 9
        else if (list(4,in+1) .eq. 0) then
c
c  This is not the last note in the group, so
c
          in = in+1
          go to 9 
        else if (list(4,in+1) .eq. nspace(ib)) then
c
c  Keep spacing the same, update tentative stop point
c
          in = in+1
          istop(ib) = in
          go to 9
        end if
c
c At this point istart and istop are good, so finalize block 
c
        itstart(ib) = list(3,istart(ib))
        nindex(ib) = nindxf(nspace(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 for upcoming block
c
        nspace(ib) = list(4,in)
        istop(ib) = in
      go to 9          
15    continue
      nb = ib
c     print*,'istart(ib),istop(ib),nspace(ib)'
c     write(*,'(24i3)')(istart(ib),istop(ib),nspace(ib),ib=1,nb)
c
c  Check for xtuplets.  Locate and split off all xtuplets into separate block 
c  groups.  Each xtup starts and ends some block, and there may be internal 
c  stops and new starts during the duration of the xtup.  Splitting off is
c  a safety against e.g. e4x3 e8 e / e8 e e e / , where 1st half is longer
c  than second.  Make a list of the nbxtup blocks w/ xtups in lbxtup()
c
      ib = 1
      nbxtup = 0
      do 90 ixt = 1 , nxtup
        if (ixt.gt.1 .and. it1xtup(ixt).eq.it1xt) go to 90
        n1xt = n1xtup(ixt)
        it1xt = it1xtup(ixt)
91      continue
        if (istop(ib) .lt. n1xt) then
c
c  Block ends before xtup starts, so go to next block
c
          ib = ib+1
          go to 91
        end if
c
c  Know ib ends after xtup starts, and must start at or before xtup.  If "at",
c  don't need to start new block.
c   
        if (itstart(ib) .lt. it1xt) then
c
c  But now must add new block
c
          if (list(1,n1xt) .gt. 1) then
c
c  Back up to most recent note with earlier time 
c
            do 92 in = n1xt-1 , 1 , -1
              if (list(3,in) .ne. it1xt) go to 93
92          continue
          else
            in = n1xt-1
          end if

93        continue
c
c  "in" is now the last note of new version of ib.  Insert new block
c
          nb = nb+1
          do 94 jb = nb , ib+1 , -1
            nindex(jb) = nindex(jb-1)
            istop(jb) = istop(jb-1)
            istart(jb) = istart(jb-1)
            nspace(jb) = nspace(jb-1)
            itstart(jb) = itstart(jb-1)
94        continue
          istop(ib) = in
          istart(ib+1) = in+1
          itstart(ib+1) = list(3,in+1)
          ib = ib+1
        end if
c
c  Add ib to the list of blocks in which xtups start.
c
        if (nbxtup.eq.0 .or. lbxtup(nbxtup).ne.ib) then
          nbxtup = nbxtup+1
          lbxtup(nbxtup) = ib
        end if
c
c  Check for block ending time relative to xtup.  Check has to be based on
c   time rather than note number in list.
c
        n2xt = n2xtup(ixt)
        it2xt = list(3,n2xt)+nodur(list(1,n2xt),list(2,n2xt))
c     print*,'Checking end times of xtups. it2xt:',it2xt
95      continue
        itstopib = list(3,istop(ib))+nspace(ib)
        if (itstopib .lt. it2xt) then
          ib = ib+1
          go to 95
        end if
        if (itstopib .ne. it2xt) then
c
c  Must stop a block at it2xt, restart a new one.  Look back from istop for
c   most recent note w/ proper stopping time
c
          do 96 in = istop(ib)-1 , 1 , -1
            if (list(3,in)+nspace(ib) .eq. it2xt) go to 97
96        continue
          print*,'Should not BEEE here!'
          stop
97        continue
c
c  Now "in" is the list place where new stop goes 
c
          nb = nb+1
          do 98 jb = nb , ib+1 , -1
            istop(jb) = istop(jb-1)
            istart(jb) = istart(jb-1)
            nindex(jb) = nindex(jb-1)
            nspace(jb) = nspace(jb-1)
            itstart(jb) = itstart(jb-1)
98        continue
          istop(ib) = in
          istart(ib+1) = in+1
          itstart(ib+1) = list(3,in+1)
          ib = ib+1
        end if
90    continue
c     print*
c     print*,'istart,istop,itstart,nspace:'
c     write(*,'(24i3)')(istart(ib),istop(ib),itstart(ib),nspace(ib),
c    *                   ib=1,nb)
c
c  Invert the list of places, to make it easier to analyze a voice
c
      do 13 in = 1 , ntot
        ipl(list(1,in),list(2,in)) = ior(ipl(list(1,in),list(2,in)),in)
13    continue 
c     print*
c     write(*,'(26i3)')(list(1,in),in=1,ntot)
c     write(*,'(26i3)')(list(2,in),in=1,ntot)
c     write(*,'(26i3)')(list(3,in),in=1,ntot)
c     write(*,'(26i3)')(list(4,in),in=1,ntot)
c     write(*,'(26i3)')(nodur(list(1,in),list(2,in)),in=1,ntot)
c     write(*,'(26i3)')(iand(islur(list(1,in),list(2,in)),30720)/2048,
c    *                  in=1,ntot)
c     write(*,'(1x,26a3)')(ornq(list(1,in),list(2,in)),in=1,ntot)
c     write(*,'(1x,26a3)')(accq(list(1,in),list(2,in)),in=1,ntot)
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  itglp2 is time from start of gulp to end of current bar.
c
          nfbbar = 0
          do 80 ifb = 1 , nfb(ivx)
            if (it1fb(ivx,ifb).ge.itglp2) go to 81
            nfbbar = nfbbar+1
            numbms(ivx) = numbms(ivx)+1
            numnew = numbms(ivx)
c
c  Times from beginning of bar
c
            itbb1 = it1fb(ivx,ifb)-itglp1
            itbb2 = it2fb(ivx,ifb)-itglp1
            do 83 ip = 1 , nn(ivx)
              if (list(3,iand(255,ipl(ivx,ip))).eq.itbb1) then
                nip1fb = ip
c
c  The following loop has a problem if beam ends right before xtuplet
c  1/11/95 Did a check.  Don't know why I put in the above comment
c
c                do 84 ip1 = ip+1 , nn(ivx)
                do 84 ip1 = ip , nn(ivx)
                  if (list(3,iand(255,ipl(ivx,ip1)))+nodur(ivx,ip1)
     *                     .eq.itbb2) then
                    nip2fb = ip1
                    itbb3 = itbb2-2
                    go to 85
                  end if
84              continue
              end if
83          continue
            print*,'Timing problem w/ fixed beams'
            stop
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
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)
              it1fb(ivx,ifb) = it1fb(ivx,ifb+nfbbar)
              it2fb(ivx,ifb) = it2fb(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 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
      common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
     *    inhead,inbothd
      character*79 notexq
      character*60 instrq,titleq,compoq
      parameter (nm=7)
      character*1 sq,sepsymq(nm)
      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) then
        inhead = 16
      end if
      ndig = int(alog10(inhead+.01))+1
      write(notexq(lenline+1:lenline+ndig+10),'(i'//char(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) vskil = 2
      call writflot(vskil,notexq,lenline)
      if (.not.headlog) then
        write(11,'(a)')notexq(1:lenline)//'}{}{0}{}{0}{}{0}}'//sq//'en%'
      else 
        notexq = notexq(1:lenline)//'}{'
        lenline = lenline+2
        lcq = lc(instrq,60)
        if (lcq .gt. 0) then
          xitil = etait*glueil
          if (vshrink) xitil = 2
          notexq = notexq(1:lenline)//instrq(1:lcq)//'}{'
          lenline = lenline+lcq+2
          call writflot(xitil,notexq,lenline)
        else
          notexq = notexq(1:lenline)//'}{0'
          lenline = lenline+3
        end if
        write(11,'(a)')notexq(1:lenline)//'}%'
        notexq = '{'
        lenline = 1
        lcq = lc(titleq,60)
        if (lcq .gt. 0) then
          notexq = notexq(1:lenline)//titleq(1:lcq)
          lenline = lenline+lcq
        else
          print*
          print*,'WARNING'
          print*,
     *      '  In a title block, you have specified instrument and/or'
          print*,
     *      '  composer but no title for the piece.  To suspend'
          pause 
     *      '  processing hit <ctrl-break>, or <enter> to continue.'
        end if
        notexq = notexq(1:lenline)//'}{'
        lenline = lenline+2
        xtcil = etatc*glueil
        lcq = lc(compoq,60)
        if (lcq .eq. 0) xtcil = 2*xtcil
        if (vshrink) 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
          xcsil = etacs1*glueil
          if (vshrink) xcsil = 2
          call writflot(xcsil,notexq,lenline)
        else
          notexq = notexq(1:lenline)//'}{0' 
          lenline = lenline+3 
        end if
        write(11,'(a)')notexq(1:lenline)//'}}'//sq//'en%'
        headlog = .false.
      end if
      return
      end
      subroutine getnote(loop)
      parameter (nm=7)
            common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      character*6 figq
      character*1 accq,ulq,sepsymq,sq,rptfq1,rptfq2
      logical beamon,firstgulp,figbass,figcheck,isfig
      character*60 instrq,titleq,compoq
      common /combjmp/ ivbjmp,isbjmp
      common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
     *    inhead,inbothd
      common /comfig/ itfig(74),figq(74),nfigs
      common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd,
     *       npreslur,was2(nm)
      common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,
     *       movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
     *       rptprev,rptfq1,rptfq2
      common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
      common /comfb/ nfb(nm),it1fb(nm,20),it2fb(nm,20),ulfbq(nm,20),ifb
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),aftshft,
     *                nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
     *                noffseg,ngrace,nvolt,ivlit(36),iplit(36),nlit,
     *                lenlit(36),multg(37),upg(37),slurg(37),slashg(37),
     *                accgq(74),voltxtq(6),litq(36)
      logical upg,slurg,slashg,fbon,ornrpt,shifton,setis,notcrd,isbjmp,
     *        was2
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      character*128 litq
      common /comcc/ ncc(nm),itcc(nm,10),ncmidcc(nm,10),
     *               ndotmv(nm),updot(nm,20),rtdot(nm,20)
      common /combc/ bcspec
      common /comas3/ ask(1000),iask,asx(200),iasx,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/ ntrans
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,inameq(nm),idsig
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      common /comudsp/udsp(25),itudsp(25),nudsp,udoff(nm,20),nudoff(nm),
     *                 uxsp(25),ivuxsp(25),ipuxsp(25),nuxsp
      common /comask/ bar1syst,fixednew,scaldold,apt,abigpt,
     *                wheadpt,fbar,poenom
      common /comslur/ listslur,upslur(nm,2),ndxslur
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      logical mrecord,mplay,endmac,lowdot
      character*128 lineq,lnholdq
      character*80 headrq, lowerq
      character*79 inameq
      character*59 hdlndq
      character*10 voltxtq
      character*1 charq,dotq,durq,ulfbq,accgq,dumq
      logical loop,lastchar,lower,rptnd1,rptprev,bcspec,
     *        pg1r,topmods,headlog,btest,sluron
1     call getchar(lineq,iccount,charq)
      if (lastchar) return
      if (charq .eq. ' ') go to 1
      if (charq .eq. '%') then
        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
c
c  This is a note/rest.  Increase note count, then loop 'til blank
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
        notcrd = .true.
c
c  Increase note count, then loop 'til blank. Label 28 is for dotted shortcuts.
c
28      nnl(ivx) = nnl(ivx)+1
        if (ornrpt) then
c
c  Replicate ornament bits, also bit 23 for beam handling
c        
          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
        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(irest(ivx,nnl(ivx)-1),0) .and.
     *        nodur(ivx,nnl(ivx)-1) .eq. lenbar) 
     *          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 at 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)
            stop
          end if
        else if (durq .eq. 'd') then
          dotq = durq
          if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
c
c  move a dot, unless next char is not part of a number
c
            if (index('0123456789.',lineq(iccount+2:iccount+2)) .eq. 0)
     *         go to 2
            irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),19)
            call getchar(lineq,iccount,durq)
            ndotmv(ivx) = ndotmv(ivx)+1
            iccount=iccount+1
            call readnum(lineq,iccount,dumq,updot(ivx,ndotmv(ivx)))
            if (durq .eq. '-') 
     *         updot(ivx,ndotmv(ivx)) = -updot(ivx,ndotmv(ivx))
            if (index('+-',dumq) .gt. 0) then
c
c  Vertical shift also
c
              iccount=iccount+1
              call readnum(lineq,iccount,durq,rtdot(ivx,ndotmv(ivx)))
              if (dumq .eq. '-') 
     *         rtdot(ivx,ndotmv(ivx)) = -rtdot(ivx,ndotmv(ivx))
            else
              rtdot(ivx,ndotmv(ivx)) = 0.
            end if
            iccount = iccount-1
          end if
          go to 2
        else if (durq .eq. 'p') then
c
c  Full-bar rest as pause
c
          islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19)
          go to 2
        else if (durq .eq. 'b') then
c
c  Blank rest 
c
          islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29)
          go to 2
        else if (index('fsn',durq) .gt. 0) then
c
c  Accidental
c
          if (accq(ivx,nnl(ivx)) .ne. durq) then
            accq(ivx,nnl(ivx)) = durq
          else
            accq(ivx,nnl(ivx)) = char(ichar(durq)+1)
          end if
          go to 2
        else if (index('+-',durq) .gt. 0) then
          ipm = index('- +',durq)-2
          if (.not.btest(irest(ivx,nnl(ivx)),0)) then
            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; raise a rest
c
            call getchar(lineq,iccount,durq)
            call readnum(lineq,iccount,durq,fnum)
            if (lineq(iccount-1:iccount-1) .eq. '.') then 
c
c  Kluge in case there is a shortcut ".". It will have been sucked up by 
c  readnum.  (Same doesn't hold for ",")
c
               iccount = iccount-2
               go to 2
            end if
            nolev(ivx,nnl(ivx)) = 100+ipm*int(fnum+.1)
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: Set all durations to 0 except last one.  Next input will be digit
c
          iccount = iccount+1
          call readnum(lineq,iccount,durq,fnum)
          ntup = int(fnum+.1)
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 (durq .ne. ' ') then 
c
c  Vertical or horiz shift; durq must be +/-
c
                numshft = numshft+1
                iofforn = 1
                if (durq .eq. '-') iofforn = -1
                iccount = iccount+1
                call readnum(lineq,iccount,durq,xofforn)
                iccount = iccount-1
                if (numshft .eq. 1) then
c
c  Vertical shift
c
                  iofforn = iofforn*int(xofforn+.1) + 16
c
c  Turn on bit 1; set bits 2-6 to iofforn
c
                  irest(ivx,nnl(ivx)) = 
     *               ior(irest(ivx,nnl(ivx)),2+4*iofforn)
                else
c
c  Horizontal shift
c
                  iofforn = iofforn*int(xofforn*10+.01)+16
                  irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),7)
                  irest(ivx,nnl(ivx)) = 
     *               ior(irest(ivx,nnl(ivx)),ishft(iofforn,9))
                end if
                go to 30
              end if
            end if
          end if
          if (numnum .eq. 2) then
            lastlev = ifnolev(charq,ioct)
            nolev(ivx,nnl(ivx)) = lastlev
          else
            lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7)
            nolev(ivx,nnl(ivx)) = lastlev
          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. '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,max(1,nnl(ivx)-2)),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. '(') 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    
              call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,
     *           nsdat,notcrd,nolev(ivx,nnlivx))
              go to 7
            else if (charq .eq. sq) then
              call littex(islur,nnl(ivx),ivx,topmods,lineq,iccount)
              go to 7
            else if (index('0123456789#-nx_',charq) .gt. 0) then
c
c  Figure.  Must come AFTER the first note of xtup
c
              nfig1 = nfigs+1
              call getfig(itoff(nfig1),charq,lineq,iccount,
     *                    isfig(nnl(ivx)),itfig(nfig1),itsofar(1),
     *                    0,figq(nfig1),ivx,nfigs)
              go to 7
            else if (charq .eq. 'X') then
              call getchar(lineq,iccount,durq)
              if (index('+-',durq) .gt. 0) iccount = iccount+1
              call readnum(lineq,iccount,dumq,fnum)
              if (durq .eq. '-') fnum = -fnum
              if (dumq .ne. 'p') then
                fnum = fnum*wheadpt 
              else
                call getchar(lineq,iccount,durq)
              end if
c
c  User-defined hardspace in xtup.  Goes before next note. 
c     (At "|" or "/" check for presence and shift to udoff if there) <= later 
c
              nuxsp = nuxsp+1
              irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),21)
              uxsp(nuxsp) = fnum
              ipuxsp(nuxsp) = nnl(ivx)
              ivuxsp(nuxsp) = ivx
              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
              icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8)) 
              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, get ' ', making ndx=0, so go past this block
c
              ndx = index('nfs+-12345678re',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 (durq .eq. '+') then
                  lastlev = lastlev+7
                else if (durq .eq. '-') then
                  lastlev = lastlev-7
                else if (durq .eq. 'e') then
                  icrdat(ncrd) = ibset(icrdat(ncrd),23) 
                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 
c
c must be a number, save it in ioct
c
                  numnum = 1
                  ioct = ndx-5
                end if
                go to 34
              end if
              if (numnum .eq. 1) then
                lastlev = ifnolev(charq,ioct)
              else
                lastlev = lastlev-3+mod(ifnolev(charq,10)-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)
41            continue 
              go to 7
            end if
c
c  End of loop for xtup options. If here, charq must be a (non-crd) note name.
c
            notcrd = .true.
8           call getchar(lineq,iccount,durq)
            if (durq .ne. ' ') then
              if (durq.eq.'+') then
                lastlev = lastlev+7
              else if (durq.eq.'-') then
                lastlev = lastlev-7
              else if (index('fsn',durq) .gt. 0) then
                if (accq(ivx,nnl(ivx)) .ne. durq) then
                  accq(ivx,nnl(ivx)) = durq
                else
                  accq(ivx,nnl(ivx)) = char(ichar(durq)+1)
                end if
              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.
c
              lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7)
              nolev(ivx,nnl(ivx)) = lastlev
              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
6         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
        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)
          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)
          go to 2
        else if (durq .eq. ',') then
c
c  2:1 pattern
c
          idotform = 3
        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 
c
c  Now flow to duration setting, if durq=' '
c
        else if (durq .ne. ' ') then
          print*,'Illegal character in note: ',durq,', ivx,nn:',
     *        ivx,nnl(ivx)
          stop
        end if
        if (.not.btest(irest(ivx,nnl(ivx)),0)) then
          if (numnum .eq. 2) then
            lastlev = ifnolev(charq,ioct)
            nolev(ivx,nnl(ivx)) = lastlev
          else
            lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7)
            nolev(ivx,nnl(ivx)) = lastlev
          end if
          do 43 npreslur = npreslur , 1 , -1
c
c  Set level for preslur on normal note, non-chord
c
            call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev)
43        continue
        end if
        if (idotform .gt. 0) then
          if (idotform .eq. 1) then
            nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)*3/2
          else if (idotform .eq. 2) then
            nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3
          else if (idotform .eq. 3) then
            nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)
          else if (idotform .eq. 4) then
            nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2
          end if
        else if (btest(islur(ivx,nnl(ivx)),19)) then
          nodur(ivx,nnl(ivx)) = lenbar
        else if (ibarmbr.ne.nbars+1) then
          nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)
        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 (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 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
c  Bits in icrdot:
c     0-6   10*abs(vertical dot shift in \internote) + 64
c     7-13  10*abs(horiaontal dot shift in \internote) + 64
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
        icrdat(ncrd) = ior(nnl(ivx),ishft(ivx,8)) 
        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)
        ndx = index('nfs+-12345678red',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 (durq .eq. '+') then
            lastlev = lastlev+7
          else if (durq .eq. '-') then
            lastlev = lastlev-7
          else if (durq .eq. 'e') then
            icrdat(ncrd) = ibset(icrdat(ncrd),23) 
          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. '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) = int(fnum*10+.5)+64 
              else
                icrdot(ncrd) = -int(fnum*10+.5)+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 = int(fnum*10+.5)+64 
                else
                  ifnum = -int(fnum*10+.5)+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 number, save it in ioct
c
            numnum = 1
            ioct = ndx-5
          end if
          go to 25
        end if
        if (numnum .eq. 1) then
          lastlev = ifnolev(charq,ioct)
        else
          lastlev = lastlev-3+mod(ifnolev(charq,10)-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
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, accgq: 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) = int(fnum+.1)
        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
        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
          accgq(ing) = 'x'
          ioct = 0
          if (ing .gt. ngstrt(ngrace)) then
55          call getchar(lineq,iccount,charq)
            if (charq .eq. ' ') go to 55
          endif
9         call getchar(lineq,iccount,durq)
          if (durq .ne. ' ') then
            if (durq.eq.'+') then
              lastlev = lastlev+7
            else if (durq.eq.'-') then
              lastlev = lastlev-7
            else if (index('fsn',durq) .gt. 0) then
              if (accgq(ing) .ne. durq) then
                accgq(ing) = durq
              else
c
c  Double accidental
c
                accgq(ing) = char(ichar(durq)+1)
              end if
            else
              ioct = ichar(durq)-48
            end if
            go to 9
          end if
          if (ioct .gt. 0) then
            lastlev = ifnolev(charq,ioct)
          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)
            end if      
            lastlev = lastlev-3+mod(ifnolev(charq,10)-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
      else if (charq .eq. sq) then
c
c  Literal TeX string
c
        call littex(islur,nnl(ivx)+1,ivx,topmods,lineq,iccount)
      else if (charq .eq. 'o') then
c
c  Ornament on non-xtup note.  Symbol must come AFTER the affected note
c
        if (notcrd) then
          nole = nolev(ivx,nnl(ivx))
        else
          nole = iand(127,ishft(icrdat(ncrd),-12))
        end if
        call getorn(lineq,iccount,iornq(ivx,nnl(ivx)),
     *       iornq(ivx,max(1,nnl(ivx)-1)),ornrpt,noffseg,nnl(ivx),ivx,
     *      .true.,notcrd,nole)
      else if (index('st()',charq) .gt. 0) then
        nnlivx = nnl(ivx)
        if (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    
        call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,nsdat,
     *        notcrd,nolev(ivx,nnlivx))
      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
      else if (index('0123456789#-nx_',charq) .gt. 0) then
c
c  We have a figure.  Must come AFTER the note it goes under
c
c       nfigs = nfigs+1
        nfig1 = nfigs+1
        call getfig(itoff(nfig1),charq,lineq,iccount,isfig(nnl(ivx)),
     *       itfig(nfig1),itsofar(1),nodur(ivx,nnl(ivx)),figq(nfig1),
     *       ivx,nfigs)
      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' 
        it1fb(ivx,nfb(ivx)) = itsofar(ivx)
        nadj = 0
17      call getchar(lineq,iccount,charq)  
        if (index('ul',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)
          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 .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 = int(fnum+.1)
          if (charq .eq. '-') iadj = -iadj
          if (nadj .eq. 1) then
c
c  This is a level shift.  Note if 0 was entered, iadj = 15 (OLD)
c  This is a level shift.  Note if 0 was entered, iadj = 30
c
            ipl(ivx,nnl(ivx)+1) = 
c    *           ior(ipl(ivx,nnl(ivx)+1),ishft(iadj+15,11))
     *           ior(ipl(ivx,nnl(ivx)+1),ishft(iadj+30,11))
          else if (nadj .eq. 2) then
c
c  Must be a slope shift
c
            ipl(ivx,nnl(ivx)+1) = 
     *           ior(ipl(ivx,nnl(ivx)+1),ishft(iadj+30,17))
          else
c
c  Beam-thk fine tune
c
            islur(ivx,nnl(ivx)+1) = 
     *           ior(islur(ivx,nnl(ivx)+1),ishft(iadj,27))
          end if
          go to 17
        end if    
      else if (charq .eq. ']') then
        call getchar(lineq,iccount,charq)  
c       if (charq .eq. ' ') then
        if (index('j ',charq) .gt. 0) then
c
c  Since ']' comes AFTER note, itsofar has been updated.  Set ending signal.
c
          it2fb(ivx,nfb(ivx)) = itsofar(ivx)
          fbon = .false.
          if (charq .eq. 'j') then
            irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),23)
          end if
        else if (charq .eq. '[') then
c
c  Only other possibility is "[" for multiplicity down-up signal
c
          islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),20) 
        end if
      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'
          stop
        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
          read(10,'(a)')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 = fmovbrk+.1
          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 = fnum+.1
            go to 31
          else if (durq .eq. 'i') then
            iccount = iccount+1
            call readnum(lineq,iccount,durq,parmov)
            go to 31
          end if
cc
cc  Check if endsymbol was set; if not, set to 'D'.  rptfq2 is set for every M
cc
c          if (rptnd1) then
c            rptnd1 = .false.
c            rptfq2 = rptfq1
c          else
c            rptfq2 = 'D'
c          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'
          stop
        end if
c
c  Set flag for lower string & read it in
c        
        lower = .true.
        read(10,'(a)')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'
          stop
        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
      else if (charq .eq. 'C') then
c
c  Clef change on next note.  Set bits 11,12,13,14.  Won't allow in 2nd voice
c
        if (nnl(iv) .gt. 0) ncc(iv) = ncc(iv)+1
        itcc(iv,ncc(iv)) = itsofar(iv)
        isl = ibset(islur(iv,nnl(iv)+1),11)
        call getchar(lineq,iccount,durq)
        isl = ior(isl,ishft(numclef(durq),12))
c
c  Set marker on note with lowest voice # starting at same time.
c
        ncmidcc(iv,ncc(iv)) = 35-2*iand(7,ishft(isl,-12))
        if (iv .eq. 1) then
          isl = ibset(isl,15)
        else
c         do 13 iiv = 1 , iv-1
          do 13 iiv = 1 , iv
c++
            nnliiv = nnl(iiv)
            if (iiv .eq. iv) nnliiv = nnliiv+1
c++
            itother = 0
c           do 14 iip = 1 , nnl(iiv)
            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       islur(iv,nnl(iv)+1) = isl
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 (durq .eq. 'r') then
          islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),6)
          rptfq1 = durq
          rptprev = .true.
          go to 10
        else if (durq .eq. 'd') then
          rptprev = .true.
          rptfq1 = durq
          islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),8)
          go to 10
        else if (durq .eq. 'D') then
          islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),26)
          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
        write(11,'(a)')sq//'headline={'//sq//'ifodd'//sq//'pageno'
     *     //sq//'rhead'//sq//'else'//sq//'lhead'//sq//'fi}%'
        npg1 = 0
        pg1r = .true.
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) pg1r = .false.
        else if (durq .eq. 'r') then
          if (npg1.gt.0 .and. mod(npg1,2).eq.0) pg1r = .false.
        end if
        hdlndq = sq//'def'//sq//'rhead{'//sq//'tempo'//sq
        if (pg1r) then
c
c  Normal; odds on right
c
          hdlndq = hdlndq(1:18)
     *       //'hfil'//sq//'folio}'//sq//'def'//sq//'lhead{'//sq
     *       //'tempo'//sq//'folio'//sq//'hfil}%'
        else
          hdlndq = hdlndq(1:18)
     *       //'folio'//sq//'hfil}'//sq//'def'//sq//'lhead{'//sq
     *       //'tempo'//sq//'hfil'//sq//'folio}%'
        end if
        write(11,'(a)')hdlndq
        if (npg1 .gt. 0) then
c
c  Write out starting page number
c
          if (npg1 .lt. 10) then
            write(11,'(a7,i1,a1)')sq//'pageno',npg1,'%'
          else if (npg1 .lt. 100) then
            write(11,'(a7,i2,a1)')sq//'pageno',npg1,'%'
          else 
            write(11,'(a7,i3,a1)')sq//'pageno',npg1,'%'
          end if
        end if
      else if (charq .eq. 'W') then
c
c  Just get two more characters (.n), they were used in pmxa
c
        call getchar(lineq,iccount,durq)
        call getchar(lineq,iccount,durq)
      else if (charq .eq. 'T') then
        headlog = .true.
        inhead = 0
        call getchar(lineq,iccount,durq)
        if (durq .eq. 'i') then
          read(10,'(a)')instrq
c
c  A kluge for parts from separate score file for later movements.
c 
          if (instrq(1:1) .eq. ' ') headlog = .false.
        else if (durq .eq. 't') then
21        call getchar(lineq,iccount,durq)
c
c  Optionally can include extra vertical \internotes above inbothd
c
          if (index('0123456789',durq) .gt. 0) then
            inhead = 10*inhead+ichar(durq)-48
            go to 21
          end if
          read(10,'(a)')titleq
        else
          read(10,'(a)')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
          write(11,'(a)')sq//'relativeaccid%'
          go to 27
        else if (durq .eq. 's') then
          bacfac = 1.e6
          go to 27
        else if (durq .eq. 'b') then
          write(11,'(a)')sq//'bigaccid%'
          accfac = bacfac
          go to 27
        else if (durq .eq. 'a') then
          call getchar(lineq,iccount,durq)
          call readnum(lineq,iccount,durq,fnum)
          iccount = iccount-1
          go to 27
        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
          go to 27
        else if (durq .eq. 'I') then
          call getchar(lineq,iccount,durq)
          call readnum(lineq,iccount,durq,gintstf)
          iccount = iccount-1
          go to 27
        else if (durq .eq. 'd') then
          lowdot = .true.
        end if
      else if (charq .eq. 'K') then
        call getchar(lineq,iccount,durq)
        num1 = 44-ichar(durq)
        iccount = iccount+1
        call readnum(lineq,iccount,durq,fnum)
        num1 = num1*int(fnum+.1)
c
c  On exit, durq='+','-'.  But only need isig if after start, else done in pmxa
c
        iccount = iccount+1
        call readnum(lineq,iccount,charq,fnum)
        if (num1 .eq. 0) then
c
c  Key change, not transposition.
c
          ipl(ivx,nnl(ivx)+1) = ibset(ipl(ivx,nnl(ivx)+1),28)
          lastisig = isig
          isig = fnum+.1 
          if (durq .eq. '-') isig = -isig
          isig = isig+idsig
        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
          ntrans = num1
          idsig = isig-isig0
        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 voice
c
          if (lenb0.ne.0 .and. firstgulp) lenbar = lenb0
          nbars = 0
          if (durq .eq. ' ') then
c
c  New voice is on next staff
c
            iv = iv+1
            ivx = iv
          else
c
c  durq must be 2nd '/'.  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
            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
              accq(ivx,j) = 'x'
              iornq(ivx,j) = 0
              ipl(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
        call getchar(lineq,iccount,charq)
        if (charq .eq. ':') then
c
c  End a group shift after this last note entered.
c
          irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),17)
          shifton = .false.
        else
          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 
          else
            call getchar(lineq,iccount,durq)
          end if
          if (durq .eq. ' ') then
c
c  User-defined hardspace.  Goes before next note. At "|" or "/" check for
c  presence and shift to udoff if there! 
c
            nudsp = nudsp+1
            iornq(ivx,nnl(ivx)+1) = ibset(iornq(ivx,nnl(ivx)+1),26)
            udsp(nudsp) = fnum
            itudsp(nudsp) = itsofar(ivx)
          else 
c
c  Only other possibilities are offsets, "S" for single, ':' for multiple
c
            nudoff(ivx) = nudoff(ivx)+1
            udoff(ivx,nudoff(ivx)) = fnum
            if (durq .eq. 'S') then
              irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),15)
            else
              irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),16)
              shifton = .true.
            end if
          end if
        end if
      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 = fnum+.1 
          macuse = ibset(macuse,macnum)
          if (btest(macuse,macnum)) close(20+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
              read(10,'(a)')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 = fnum+.0001 
          rewind(20+macnum)
          icchold = iccount
          lnholdq = lineq
          iccount = 128
          mplay = .true.
        end if
      end if
      return
      end
      subroutine getchar(lineq,iccount,charq)
      parameter (nm=7)
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,
     *       movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
     *       rptprev,rptfq1,rptfq2
      logical lastchar,rptnd1,sluron,fbon,rptprev,ornrpt
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      logical mrecord,mplay,endmac
      character*1 charq,rptfq1,rptfq2
      character*128 lineq,lnholdq
      if (iccount .eq. 128) then
        call read10(lineq,128,lastchar)
        if (lastchar) return
        if (.not. endmac) then
          iccount = 0
        else
          endmac = .false.
          iccount = icchold
          lineq = lnholdq
        end if
        if (mrecord) then
          call mrec1(lineq,iccount,ndxm)
        end if
      end if
      iccount = iccount+1
      charq = lineq(iccount:iccount)
      return
999   continue
      lastchar = .true.
      return
      end
      function log2(n)
        log2 = alog(1.*n)/0.69315+.001
      return
      end
      function ifnolev(noq,oct)
      common /comtrans/ ntrans
        character*1 noq
        integer oct
        ifnolev = 7*oct+mod(ichar(noq)-92,7)+1+ntrans
      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 ncmidf(clefq)
      character*1 clefq
      if (clefq.eq.'t' .or. clefq.eq.'0') then
        ncmidf = 35
      else if (clefq.eq.'s' .or. clefq.eq.'1') then
        ncmidf = 33
      else if (clefq.eq.'m' .or. clefq.eq.'2') then
        ncmidf = 31
      else if (clefq.eq.'a' .or. clefq.eq.'3') then
        ncmidf = 29
      else if (clefq.eq.'n' .or. clefq.eq.'4') then
        ncmidf = 27
      else if (clefq.eq.'r' .or. clefq.eq.'5') then
        ncmidf = 25
      else
        ncmidf = 23
      end if
      return
      end
      subroutine beamstrt(notexq,lnote,nornb,ihornb)
      parameter (nm=7)
            common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      character*1 accq,ulq,sepsymq,sq
      character*79 inameq
      logical beamon,firstgulp,figbass,figcheck,btest,
     *        isfig,vxtup,bar1syst,inxtup,addbrack,flipend,xto
      common /comoct/ noctup
      common /strtmid/ ihnum3,flipend(nm)
      common /comxtup/ xtupfac(nm),n2xtup(20),ixtup,vxtup(nm),inxtup,
     *                 ntupv(nm),nolev1,islope,xelsk(24),eloff
      common /comas1/ naskb,itask(20),wask(20),elask(20),iasxb,
     *                nasxb,ipasx(20),ivasx(20),wasx(20),elasx(20)
      common /comask/ bar1syst,fixednew,scaldold,apt,abigpt,
     *                wheadpt,fbar,poenom
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,inameq(nm),idsig
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      character*8 noteq
      character*79 notexq
      integer ipb(24),nornb(nm),ihornb(nm,24)
      ibc = ibmcnt(ivx)
      ipb1 = ibm1(ivx,ibc)
      multb = mult(ivx,ipb1)
      call SetupB(xelsk,nnb,sumx,sumy,ipb,islope,smed,
     *              nolev1,epns)
      lnote = 0
      if (vxtup(ivx)) then
c
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#, notelevel of middle note (or gap) in xtup
c
        ipmid = ipb1+ntupv(ivx)/2
        xnlmid = nolev(ivx,ipmid)
        if (mod(ntupv(ivx),2) .eq. 0) 
     *      xnlmid = (xnlmid+nolev(ivx,ipmid-1))/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  Place xtup number if needed
c
        if (.not.btest(islur(ivx,ipb1),31) .or. multb.le.0) 
     *      call putxtn(ntupv(ivx),iflop,multb,iud,wheadpt,poenom,
     *        nolev1,islope,slfac,xnlmid,islur(ivx,ipb1),lnote,notexq,
     *        ncmid(iv,ipb1),nlnum,eloff,iup,irest(ivx,ipb1))
c
c  Why was this here ????????
c
c         nornb(ivx) = 0
        if (multb .le. 0) then 
c
c  Put in the bracket. scale = stretch factor for bracket if there are asx's
c
          scale = xelsk(nnb)/(nnb-1)/epns
          xnsk = (ntupv(ivx)-1)*scale
          if (iup .eq. 1) then
            notexq = notexq(1:lnote)//sq//'ovbkt'
          else
            notexq = notexq(1:lnote)//sq//'unbkt'
          end if
          lnote = lnote+6
          if (iline.eq.1) then
            smed = smed/(1.-fracindent)
          end if
          xslope = 1.8*smed*slfac
          islope = ni(xslope)
          nolev1 = nlnum - smed*eloff
          if (islope .eq. 0) nolev1 = nolev1-1
          if (iup .eq. 1) nolev1 = nolev1+4
          call notefq(noteq,lnoten,nolev1,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 (islope.lt.0 .or. islope.ge.10) then
            notexq = notexq(1:lnote)//'{'
            lnote = lnote+1
            if (islope .lt. -9) then
              write(notexq(lnote+1:lnote+3),'(i3)')islope
              lnote = lnote+3
            else 
              write(notexq(lnote+1:lnote+2),'(i2)')islope
              lnote = lnote+2
            end if
            notexq = notexq(1:lnote)//'}'
            lnote = lnote+1
          else
            write(notexq(lnote+1:lnote+1),'(i1)')islope
            lnote = lnote+1
          end if
          return
        end if
      end if
c
c  Adjust start level and slope if needed
c
      iadj = iand(63,ishft(ipl(ivx,ipb1),-11))-30
      if (iadj .ne. -30) nolev1 = nolev1+iadj
      iadj = iand(63,ishft(ipl(ivx,ipb1),-17))-30
      if (iadj .ne. -30) then
        islope = islope+iadj
      end if
      iadj = iand(3,ishft(islur(ivx,ipb1),-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+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-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 for end level in forced beam.  Have to do it here since with multiple
c  voices, xelsk will not be preserved.
c
        if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
          bmlev = nolev1+6+islope*xelsk(nnb)/slfac 
          flipend(ivx) = bmlev.lt.nolev(ivx,ibm2(ivx,ibc))
        else if (ulq(ivx,ibmcnt(ivx)) .eq. 'l') then 
          bmlev = nolev1-6+islope*xelsk(nnb)/slfac 
          flipend(ivx) = bmlev.gt.nolev(ivx,ibm2(ivx,ibc))
        end if
      end if  
      call ntrbbb(multb+iadj,'i',ulq(ivx,ibc),ivx,notexq,lnote)
c
c   Put in name of start level and slope
c
      call notefq(noteq,lnoten,nolev1,ncmid(iv,ipb1))
      iasl = min(abs(islope),9)
      if (islope .lt. 0) then
        notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
        lnote = lnote+4+lnoten
        write(notexq(lnote-2:lnote),'(i2,a1)')-iasl,'}'
      else
        notexq = notexq(1:lnote)//noteq(1:lnoten)
        lnote = lnote+1+lnoten
        write(notexq(lnote:lnote),'(i1)')iasl
      end if
c
c  Check for beam-thk fine-tuning 
c
      if (iadj .gt. 0) then
        do 1 imp = multb+iadj , multb+1 , -1
          call ntrbbb(imp,'t',ulq(ivx,ibc),ivx,notexq,lnote)
1       continue
      end if
c
c  If we shifted, must close with right bracket
c
      if (addbrack) then
        notexq = notexq(1:lnote)//'}'
        lnote = lnote+1
      end if
c
c  Get 'floor' zmin for figures 
c
      if (figbass .and. iv.eq.1) then
        zmult = 1.2*(multb-1)
        ymin = 100.
        do 3 inb = 1, nnb
          if (isfig(ipb(inb))) then
            if (ulq(1,ibc) .eq. 'u') then
      	ybot = nolev(1,ipb(inb))
            else
      	ybot = islope/slfac*xelsk(inb)+nolev1-stemlen-zmult
            end if
            ymin = min(ymin,ybot)
          end if
3       continue
        maxdrop = ncmid(1,ipb1)-4-ymin+5.01
        ifigdrop(iline) = max(ifigdrop(iline),maxdrop)
      end if
c
c  Compute ornament levels if needed
c
c       if (nornb(ivx) .gt. 0) then
c       nornb(ivx) = 0
      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
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
        if (.not.btest(ipl(ivx,ip),10)) then
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+stemlen+islope*xelsk(inb)/slfac-1
     *                  +1.2*(multb-1)
c           ihornb(ivx,iorn) = max(ni(ybeam+3.5),NomOrnLev)
            ihornb(ivx,iorn) = max(ni(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 these
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+stemlen+islope*xelsk(inb)/slfac-1
     *                  +1.2*(multb-1)
c             ihornb(ivx,iorn) = max(ni(ybeam+3.5),NomOrnLev)
              ihornb(ivx,iorn) = max(ni(ybeam+3.),NomOrnLev)
            else
              ybeam = nolev1-stemlen+islope*xelsk(inb)/slfac+1
     *                  -1.2*(multb-1)
c             ihornb(ivx,iorn) = min(ni(ybeam-3.5),NomOrnLev-10)
              ihornb(ivx,iorn) = min(ni(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
cc
cc   Hecnceforth nornb(ivx) will be a counter.  Zero it out when beam is finished
cc   Start it at 1 instead of 0 so it tells if there are orns in the beam.
cc
c        nornb(ivx) = 1
      if (iorn .gt. 0) nornb(ivx)=1
c      end if
      return
      end
      subroutine beamn1(notexq,lnote)
      parameter (nm=7)
            common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      character*1 accq,ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,btest,
     *        isfig,vxtup,inxtup,isdotm,isbjmp
      common /combjmp/ ivbjmp,isbjmp
      common /comoct/ noctup
      common /comxtup/ xtupfac(nm),n2xtup(20),ixtup,vxtup(nm),inxtup,
     *                 ntupv(nm),nolev1,islope,xelsk(24),eloff
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*8 noteq
      character*79 notexq
        ip1 = ibm1(ivx,ibmcnt(ivx))
        multip = mult(ivx,ip1)
        call notefq(noteq,lnoten,nolev(ivx,list(2,jn)),ncmid(iv,ip1))
        if (vxtup(ivx) .and. multip.le.0) then
c
c  Xtuplet with no beam, just put in the right kind of note
c
          if (lnoten .eq. 1) call addblank(noteq,lnoten)
          if (multip .eq. 0) then
            notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq
          else if (multip .eq. -1) then
            notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
          end if
          lnote = lnoten+3
          return
        end if          
c
c  Check if mult. decreases from 1st note to 2nd 
c
        if (ibm2(ivx,ibmcnt(ivx)) .gt. ip1) then
          if (.not.btest(irest(ivx,ip1+1),0)) then
            multr = mult(ivx,ip1+1)
          else
            multr = mult(ivx,ip1+2)
          end if
          lnote = 0
          if (multr .lt. multip) then
            do 1 im = multip , multr+1 , -1
              call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
1           continue
          end if  
        end if  
c
c  Put in the note
c
        if (lnote .gt. 0) then
          notexq = notexq(1:lnote)//sq//'qb'
        else
          notexq = sq//'qb'
        end if
        lnote = lnote+3
c
c  Check for dot
c
        isdotm = .false.
        if (.not.vxtup(ivx)) then
          nd = nodur(ivx,list(2,jn))
          if (nd.ne.0) then
            if (2**log2(nd).ne.nd) then
              if (.not.btest(iornq(ivx,ip1),13)) then
                notexq = notexq(1:lnote)//'p'
              else
                notexq = notexq(1:lnote)//'m'
                isdotm = .true.
              end if
              lnote = lnote+1
            end if
          end if
        end if
        lnote = lnote+1
        if (.not.btest(irest(ivx,ip1),24)) then
          write(notexq(lnote:lnote),'(i1)')ivx
        else
          write(notexq(lnote:lnote),'(i1)')ivbjmp
          isbjmp = .true.
        end if 
        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 beamend(notexq,lnote)
      parameter (nm=7)
            common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      character*1 accq,ulq,sepsymq,sq,ulqq
      logical beamon,firstgulp,figbass,figcheck,flipend,btest,
     *        isfig,vxtup,inxtup,isdotm,isbjmp
      common /combjmp/ ivbjmp,isbjmp
      common /comoct/ noctup
      common /comxtup/ xtupfac(nm),n2xtup(20),ixtup,vxtup(nm),inxtup,
     *                 ntupv(nm),nolev1,islope,xelsk(24),eloff
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /strtmid/ ihnum3,flipend(nm)
      character*8 noteq
      character*79 notexq
      ip = list(2,jn)
      multip = mult(ivx,ip)
      call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
      if (vxtup(ivx) .and. multip.le.0) then
c
c  Xtuplet with no beam, just put in the right kind of note
c
        if (lnoten .eq. 1) call addblank(noteq,lnoten)
        if (multip .eq. 0) then
          notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq
        else if (multip .eq. -1) then
          notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
        end if
        lnote = lnoten+3
        return
      end if          
      lnote = 0
c
c New way, with flipend, which was computed in beamstrt.
c
      if (btest(ipl(ivx,ip),30) .and. flipend(ivx)) 
     *  ulq(ivx,ibmcnt(ivx)) = char(225-ichar(ulq(ivx,ibmcnt(ivx))))      
      if (ip .gt. ibm1(ivx,ibmcnt(ivx))) then 
c
c This is not a one-noter from beam-jump.  Check if multiplicity has increased
c
        if (btest(irest(ivx,ip-1),0)) then
c
c  Prior note is a rest, check one before that
c
          mp = mult(ivx,ip-2)
        else
          mp = mult(ivx,ip-1)
        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
        end if
      end if
c
c Now the normal beam termination
c
      if (.not. btest(irest(ivx,ip),23)) then
c
c  Don't terminate if starting a beam jump
c
        ulqq = ulq(ivx,ibmcnt(ivx))
        if (.not.isbjmp) then
          ivbm = ivx
        else
          ivbm = ivbjmp
          ulqq = char(225-ichar(ulqq))
        end if  
        call ntrbbb(1,'t',ulqq,ivbm,notexq,lnote)
      else
        ivbjmp = ivx
      end if
c
c  And now the note
c
      if (lnote .gt. 0) then
        notexq = notexq(1:lnote)//sq//'qb'
      else  
        notexq = sq//'qb'
      end if  
      lnote = lnote+3
      isdotm = .false.
      if (.not.vxtup(ivx)) then 
        if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then      
          if (.not.btest(iornq(ivx,ip),13)) then
            notexq = notexq(1:lnote)//'p'
          else
            notexq = notexq(1:lnote)//'m'
            isdotm = .true.
          end if
          lnote = lnote+1
        end if
      end if
      lnote = lnote+1
      if (.not.isbjmp) then
        write(notexq(lnote:lnote),'(i1)')ivx
      else
        write(notexq(lnote:lnote),'(i1)')ivbjmp
        isbjmp = .false.
      end if
      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=7)
            common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      character*1 accq,ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,flipend,btest,
     *        isfig,vxtup,inxtup,isdotm,isbjmp
      character*79 notexq
      common /combjmp/ ivbjmp,isbjmp
      common /comoct/ noctup
      common /strtmid/ ihnum3,flipend(nm)
      common /comxtup/ xtupfac(nm),n2xtup(20),ixtup,vxtup(nm),inxtup,
     *                 ntupv(nm),nolev1,islope,xelsk(24),eloff
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comask/ bar1syst,fixednew,scaldold,apt,abigpt,
     *                wheadpt,fbar,poenom
      character*8 noteq
        lnote = 0
        ip = list(2,jn)
        if (.not.btest(irest(ivx,ip),0)) then
          multip = mult(ivx,ip)
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))
c      print*,'In beamid, nolev, notefq:',
c    *nolev(ivx,ip),' '//noteq(1:lnoten) 
        end if       
        if (vxtup(ivx)) then
          if (multip.le.0) then
c
c  Xtuplet with no beam, just put in the right kind of note
c
            call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
            if (lnoten .eq. 1) call addblank(noteq,lnoten)
            if (multip .eq. 0) then
              notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq
            else if (multip .eq. -1) then
              notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
            end if
            lnote = lnoten+3
            return
          else if (nodur(ivx,ip).eq.0) then
c
c  In the 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
              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)/2
              xnlmid = nolev(ivx,ipmid)
              if (mod(ntupv(ivx),2) .eq. 0) 
     *          xnlmid = (xnlmid+nolev(ivx,ipmid-1))/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)) call putxtn(ntupv(ivx),
     *            iflop,multip,iud,wheadpt,poenom,nolev1,islope,slfac,
     *            xnlmid,islur(ivx,ip),lnote,notexq,ncmid(iv,ip),nlnum,
     *            eloff,iup,irest(ivx,ip))
              call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
            else
c
c  Intermediate note of xtup
c      
              call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
            end if  
          else 
c
c  Last note of xtup
c
            call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
          end if
        else if (btest(irest(ivx,ip),0)) then
          call notex(notexq,lnote)
          return
        else
          call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
        end if          
c
c Check if multiplicity changes in a way requiring action
c
        ipleft = ip-1
        if (btest(irest(ivx,ipleft),0)) ipleft = ipleft-1
        if (.not.btest(islur(ivx,ipleft),20)) then
          multl = mult(ivx,ipleft)
        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 = mult(ivx,ipright)
        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 (mua .ge. 0) then
            call ntrbbb(multip,'n',ulq(ivx,ibmcnt(ivx)),
     *                  ivx,notexq,lnote)
          else if (multl .ge. multr) then
            do 1 im = multip , 1+multr, -1 
              call ntrbbb(im,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
1           continue
          else
            do 2 im = 1+multr, multip 
              call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
2           continue
            call ntrbbb(multr,'n',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.
c       if (.not.vxtup(ivx) .and. 2**log2(nodur(ivx,ip)).ne.
c    *          nodur(ivx,ip)) then      
        if (.not.vxtup(ivx)) then
          if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then      
c           if (ornq(ivx,ip) .ne. ')') 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
        lnote = lnote+1
        if (.not.isbjmp) then
          write(notexq(lnote:lnote),'(i1)')ivx
        else
          write(notexq(lnote:lnote),'(i1)')ivbjmp
        end if
        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 ntrbbb(n,char1q,ulqq,iv,notexq,lnote)
c
c  This appends to notexq e.g. '\ibbbu1'
c
      character*79 notexq
      character*1 char1q,ulqq
      if (lnote .gt. 0) then
        notexq = notexq(1:lnote)//char(92)//char1q
      else
        notexq = char(92)//char1q
      end if
      lnote = lnote+2
      do 3 im = 1 , n
        notexq = notexq(1:lnote)//'b'
        lnote = lnote+1
3     continue
      notexq = notexq(1:lnote)//ulqq//char(48+iv)
      lnote = lnote+2
      return
      end
      subroutine addstr(notexq,lnote,soutq,lsout)
        character*(*) notexq
        character*80 soutq
        if (lsout+lnote .gt. 72) then
          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 notefq(noteq,lnote,nolev,ncmid)
        common /comoct/ noctup
        character*8 noteq
        character*1 upcaseq,noteqt
        nupfroma = mod(nolev+1,7)
        iname = 97+nupfroma
        ioctup = (nolev+1)/7-4
        noteqt = char(iname)
        if (ncmid .eq. 23) noteqt = upcaseq(noteqt)
        if (ioctup .eq. noctup) then
          lnote = 1
          noteq = noteqt
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)')'{',(char(39),i=noctup,ioctup-1),
     *                        noteqt,'}' 
          lnote = 3+ioctup-noctup
          noctup = ioctup
        else
c
c  Lower octave
c
          write(noteq,'(8a1)')'{',(char(96),i=ioctup,noctup-1),
     *                        noteqt,'}' 
          lnote = 3+noctup-ioctup
          noctup = ioctup
        end if
      return
      end
      subroutine notex(notexq,lnote)
      parameter (nm=7)
            common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*1 accq,ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,
     *        isfig,ispoi,btest
      character*1 udq,udqq,dotq
      character*79 notexq
      character*8 noteq,restq
      common /compoi/ ispoi
        ip = list(2,jn)
        nole = nolev(ivx,ip)
        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
        if (figbass .and. ivx.eq.1 .and. isfig(ip) 
     *                    .and. .not.btest(irest(ivx,ip),0)) then
          if (udq .eq. 'u') then
c
c  Upper 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(1,ip)+4 
          ifigdrop(iline) = max(ifigdrop(iline),int(4-zmin+.5))
        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
            notexq =sq//'zbreve'//noteq(1:lnoten)//sq//'sk'
            lnote = lnoten+10
          else
            dotq = 'p'
c           if (ornq(ivx,ip) .eq. ')') dotq='m'
            if (btest(iornq(ivx,ip),13)) dotq='m'
            if (nodu .eq. 12) then
              notexq =sq//'c'//udq//dotq//noteq(1:lnoten)
              lnote = lnoten+4
            else if (nodu .eq. 24) then
              notexq =sq//'q'//udq//dotq//noteq(1:lnoten)
              lnote = lnoten+4
            else if (nodu .eq. 48) then
              notexq =sq//'h'//udq//dotq//noteq(1:lnoten)
              lnote = lnoten+4
            else if (nodu .eq. 96) then
              notexq =sq//'whp'//noteq(1:lnoten)
              lnote = lnoten+4
            else if (nodu .eq. 6) then
              notexq =sq//'cc'//udq//dotq//noteq(1:lnoten)
              lnote = lnoten+5
              ispoi = .true.
            else if (nodu .eq. 3) then
              notexq =sq//'ccc'//udq//dotq//noteq(1:lnoten)
              lnote = lnoten+6
              ispoi = .true.
            end if
            if (dotq .eq. 'm') then
c
c  Need another call to the note, in case the first on 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 (.not.btest(islur(ivx,ip),19)) then
c
c  Rest, but not full-bar-pause
c
          lnote = 0
          nole = mod(nole+20,100)-20
          if (btest(islur(ivx,ip),29)) then
c
c  Blank rest
c
            notexq = sq//'sk'
            lnote = 3
          else if (nodu .le. 24) then
c
c  Normal rest < or = quarter
c
            if (nodu .eq. 2) then
              restq =sq//'hs'
            else if (nodu .le. 6) then
              restq =sq//'qs'
            else if (nodu .le. 12) then
              restq =sq//'ds'
            else 
              restq =sq//'qp'
            end if
            lrest = 3
            if (2**log2(nodu) .ne. nodu) then
              restq = restq(1:3)//'p'
              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 = char(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
              if (2**log2(nodu) .ne. nodu) then
c
c  Have dot in raised rest.  must put in hbox!
c
                notexq = notexq(1:lnote)//sq//'hbox{'
                lnote = lnote+6
              end if
              notexq = notexq(1:lnote)//restq(1:lrest)
              lnote = lnote+lrest
              if (2**log2(nodu) .ne. nodu) then
                notexq = notexq(1:lnote)//'}'
                lnote = lnote+1
              end if
            end if
          else
c
c  Half or whole rest
c
            if (nole .eq. 0) then
              if (nodu .le. 48) then
                notexq =sq//'hpause'
                lnote = 7
              else 
                notexq =sq//'pause'
                lnote = 6
              end if
              if (2**log2(nodu) .ne. nodu) then
                notexq = notexq(1:lnote)//'p'
                lnote = lnote+1
              end if
            else
              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. 64) then
                notexq = sq//'liftpause'
                lnote = 10
              else
                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 = char(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
        else
c
c  Full-bar-pause
c
          notexq = sq//'pause'
          lnote = 6
        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
      subroutine findbeam(ibmrep,numbms,mapfb)
c
c  Called once per voice per bar, after setting forced beams.
c
      parameter (nm=7)
      dimension mask(49,3),nummask(3),eqonly(49,3)
      integer numbms(nm),ipr(48),nip1(0:47),nip2(0:47),mapfb(4),itr(48),
     *        nodue(48)
      logical short(48),eqonly
            common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      common /combeam/ ibmtyp
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*1 accq,ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,
     *        isfig,btest
      data nip1,nip2 /96*0/ 
      data nummask / 29 , 49 , 12 /
      data mask  
     * /  65535,     4095,    65520,      255,    65280,       63,
     *      252,    16128,    64512,       15,      240,     3840,
     *    61440,        7,       14,      112,      224,     1792,
     *     3584,    28672,    57344,        3,       12,       48,
     *      192,      768,     3072,    12288,    49152, 20*0 ,
     * 16777215,    65535, 16776960,     4095,    65520,  1048320,
     * 16773120,      255,    65280, 16711680,       63,      252,
     *    16128,    64512,  4128768, 16515072,       15,       60,
     *      240,     3840,    15360,    61440,   983040,  3932160,
     * 15728640,        7,       14,      112,      224,     1792,
     *     3584,    28672,    57344,   458752,   917504,  7340032,
     * 14680064,        3,       12,       48,      192,      768,
     *     3072,    12288,    49152,   196608,   786432,  3145728,
     * 12582912,
     *     4095,      255,     4080,       15,      240,     3840,
     *        3,       12,       48,      192,      768,     3072,
     *  37*0 /
      data eqonly /3*.true.,46*.false.,7*.true.,91*.false./
      ip = 0
      nreal = 0
1     continue
        ip = ip+1
        if (ip .gt. nn(ivx)) go to 9
11      if (nodur(ivx,ip).eq.0) then
          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++  Rule out notes that have 'alone'-flag set
     *   .and..not.btest(islur(ivx,ip),18) 
        ipr(nreal) = ip
        itr(nreal) = list(3,iand(255,ipl(ivx,ip)))
        if (nodue(nreal) .eq. 1) then
          if (mod(list(3,iand(255,ipl(ivx,ip))),2) .eq. 0) then
c 
c  Start of 32nd gap, lump with following note
c
            ip = ip+1
            nodue(nreal) = 1+nodur(ivx,ip)
          else
c
c  End of 32nd gap, lump with preceeding note
c
            nreal = nreal-1
            nodue(nreal) = 1+nodue(nreal)
          end if
        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
            if (mod(list(3,iand(255,ipl(ivx,nip2(is2))))
     *           +nodur(ivx,nip2(is2)),2) .ne. 0) 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 logbeam(numnew,nip1,nip2)
      parameter (nm=7)
            common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      common /comfb/ nfb(nm),it1fb(nm,20),it2fb(nm,20),ulfbq(nm,20),ifb
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*1 accq,ulq,sepsymq,sq,ulfq,ulfbq
      logical beamon,firstgulp,figbass,figcheck,isfig,isxtup,btest
      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.
      elskbm = 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
          mult(ivx,iip) = igetbits(islur(ivx,nip1),3,22)
        else if (.not.isxtup) then
          if (nodur(ivx,iip) .gt. 0) then
            mult(ivx,iip) = 4-log2(nodur(ivx,iip))
          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
c
          multx = int(10.5+2.929+(0.952*alog(1.+iip-iip1)- 
     *                   alog(nodur(ivx,iip)/2.))/0.69315)-10
          do 74 iiip = iip1 , iip
            mult(ivx,iiip) = multx
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
        ulq(ivx,ifb) = ulfbq(ivx,ifb)
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) = 
c    *      ulfq(sum/(nip2-nip1+1),ncmid(iv,nip1))
     *      ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1))
      end if
      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
      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
      subroutine topfile(basenameq,lbase,nv,clefq,noinst,musicsize,
     *                   xinstf1,mtrnmp,mtrdnp,vshrink,fbar)
      parameter (nm=7)
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,inameq(nm),idsig
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      common /comnvi/ nvi(nm)
      character*79 inameq
      character*24 basenameq,fmtq
      character*5 fbarq
      character*1 clefq(nm),sq
      common /comstart/ nstartq,lstart(15),facmtr
      character*6 nstartq(15)
      logical vshrink,lowdot
      sq = char(92)                  
      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'
      write(11,'(a)')sq//'input musixmad'
c
c Need to input musixmad to permit more slurs.  
c
      if (musicsize .eq. 20) then
        write(11,'(a)')sq//'normalmusicsize%'
      else
        write(11,'(a)')sq//'smallmusicsize%'
      end if
      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=',int(widthpt+.1),'pt'
      write(11,'(a7,i3,a2)')sq//'vsize=',int(height+.1),'pt'
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}' 
      write(11,'(a19,i1,a1)')sq//'def'//sq//'nbinstruments{',
     *     abs(noinst),'}'
      iv = 0
      do 1 iinst = 1 , abs(noinst)
        if (noinst .gt. 0) then
c
c  The old way, only inst #1 can have >1 voice.
c
          if (noinst.eq.nv .or. iinst.gt.1) then
            nstaves = 1
          else
            nstaves = nv-noinst+1
          end if
        else
c
c  The new way
c
          nstaves = nvi(iinst)
        end if
        write(11,'(a)')sq//'setstaffs'//char(48+iinst)
     *            //char(48+nstaves)
        iv = iv+1
        if (nstaves .eq. 1) then
          fmtq = char(48+numclef(clefq(iv)))
          lfmtq = 1
        else
          fmtq = '{'//char(48+numclef(clefq(iv)))
          lfmtq = 2
          do 2 k = 2 , nstaves
            iv = iv+1
            fmtq = fmtq(1:lfmtq)//char(48+numclef(clefq(iv)))
            lfmtq = lfmtq+1
2         continue
          fmtq = fmtq(1:lfmtq)//'}'
          lfmtq = lfmtq+1
        end if
        write(11,'(a)')sq//'setclef'//char(48+iinst)//fmtq(1:lfmtq)
        do 3 lname = 79 , 2 , -1
          if (inameq(iinst)(lname:lname) .ne. ' ') go to 4
3       continue
4       continue
        write(11,'(a8,i1,a)')sq//'setname',iinst,
     *         '{'//inameq(iinst)(1:lname)//'}'
1     continue
      write(11,'(a18,i2,a2)')sq//'generalsignature{',isig,'}%'
      call wgmeter(mtrnmp,mtrdnp)
      ipi = fracindent*widthpt+.1
      if (ipi .lt. 10) then
        write(11,'(a11,i1,a2)')sq//'parindent ',ipi,'pt'
      else
        write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt'
      end if
      write(11,'(a)')sq//'elemskip1pt'//sq//'afterruleskip'
     *    //fbarq//'pt'//sq//'beforeruleskip0pt'//sq//'relax'
      vshrink = xinstf1.gt.20.
      if (.not.vshrink) then
        if (xinstf1 .lt. 9.95) then
          fmtq = '(a,f3.1,a)'
        else 
          fmtq = '(a,f4.1,a)'
        end if
        write(11,fmtq)sq//'stafftopmarg0pt'//sq//'staffbotmarg0pt'//sq//
     *    'interstaff{',xinstf1,'}'//sq//'relax'
        xinsnow = xinstf1
      else
        write(11,'(a)')sq//'stafftopmarg0pt'//
     *         sq//'staffbotmarg5'//sq//'Interligne'//sq//
     *         'interstaff{10}'//sq//'relax'
        xinsnow = 10.
      end if
      if (nv.eq.1) write(11,'(a)')sq//'nostartrule'
      write(11,'(a)')sq//'readmod{'//basenameq(1:lbase)//'}'
      write(11,'(a)')sq//'startmuflex'//sq//'startpiece'//sq//
     *      'addspace'//sq//'afterruleskip%'
      return
      end
      function numclef(clefq)
        character*1 clefq
        if (ichar(clefq) .lt. 55) then
          numclef = ichar(clefq)-48
        else
          numclef = index('tsmanrb',clefq)-1
        end if
      return
      end
      function ni(x)
        if (x .ge. 0.) then
          ni = x+0.5001
        else
          ni = x-0.5001
        end if
      return
      end
      function nindxf(nspace)
        nindxf = 2*alog(nspace*1.)/0.69315 + 1.3
      return
      end
      function feon(time)
      common /comeon/ eonk,ewmxk
c       feon = max(1.8,1.+alog(time/2)/.69315)
c       feon = sqrt(time/2)
        feon = sqrt(time/2)**(1.-eonk)*ewmxk
      return
      end
      subroutine setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
c
c  Sets last 2 args depending on 1st 2, (logical) num, denom.
c  ibmtyp = 1, 2, or 3 defines set of masks for beam groupings.
c  1: all duple meters
c  2: triple w/ denom=4, subdivide in groups of 2 8ths
c  3: triple w/ denom=8, subdivide in groups of 3 8ths
c  Note that lenbar is set at top or when 'm' symbol is read in getnote
c
      if (mtrdenl .eq. 4) then
        if (mod(mtrnuml,3).eq.0) then
          ibmtyp = 2
          ibmrep = mtrnuml/3
        else
          ibmtyp = 1
          ibmrep = mtrnuml/2
        end if
      else if (mtrdenl .eq. 2) then
        ibmtyp = 1
        if (mtrnuml .eq. 3) then
          ibmrep = 3
        else
          ibmrep = 2*mtrnuml/mtrdenl
        end if
      else 
c
c  Assumes mtrdenl=8 and 3/8, 6/8, 9/8, or 12/8
c
        ibmtyp = 3
        ibmrep = mtrnuml/3
      end if
c
c  Reset so we don't keep writing new meters
c
      mtrnuml = 0
c
c  Prevent ibmrep=0.  Needed for odd bars, e.g. 1/8, where beams don't matter
c
      ibmrep = max(ibmrep,1)
      return
      end
      subroutine wgmeter(mtrnmp,mtrdnp)
      character*1 sq
      if (mtrdnp .eq. 0) return
      sq=char(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
      function lc(stringq,leng)
        character*(*) stringq
        do 1 kc = leng , 1 , -1
          if (stringq(kc:kc).ne.' ') then
            lc = kc
            return
          end if
1       continue
        lc = 0
      return
      end
      function upcaseq(chq)
      character*1 chq,upcaseq
        if (ichar(chq).ge.61.and.ichar(chq).lt.122) then
          upcaseq = char(ichar(chq)-32)
        else
          upcaseq = chq
          print*,'Warning, upcaseq was called with improper argument: '
     *            //chq
      stop
        end if
      return
      end
      subroutine addblank(noteq,lnoten)
      character*8 noteq
      character*1 tchar
      tchar = noteq
      noteq = ' '//tchar
      lnoten = 2
      return
      end
      subroutine doslur(nolev,isdat1,isdat2,nsdat,ip,iv,kv,nv,beamon,
     *       ncm,soutq,lsout,ulq,islur,ipl,iornq,islhgt)
c
c  Called once per main note.
c 
      parameter (nm=7)
      integer*4 isdat1(202),isdat2(202)
      common /comslur/ listslur,upslur(nm,2),ndxslur
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      common /comsln/ is1n1,is2n1,irzbnd,isnx
      character*1 ulq,slurudq,udfq,udqq
      character*79 notexq
      character*8 noteq
      character*80 soutq
      logical upslur,beamon,btest,stemup,iscrd,sfound,tfound,tmove
c
c  Bits in isdat1:
c  0-2      iv
c  3-10     ip
c  11       start/stop switch
c  12       kv
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  6-11     voff1 1-63  =>  -31...+31
c  12-18    hoff1 1-127 => -6.3...+6.3
c  19-25    nolev
c
c  In listslur bit ib is on if slur index ib is in use, ib=0-8.
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
        stemup = ivx .gt. nv
      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. iand(7,isdat1(isdat)) .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
      do 1 isdat = 1 , nsdat
        isdata = isdat1(isdat)
c      print*
c      print*,'In doslur'
c      call report(nsdat,isdat1,isdat2)
        if (iv .eq. iand(7,isdata) .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, so 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
cc
cc  For single voice, check top & bottom note of chord
cc
c                if (nolevs .eq. maxlev) then
c                  slurudq = 'u'
c                else if (nolevs .eq.minlev) then
c                  slurudq = 'd'
c                end if
                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
c            if ((btest(iornq,11).or.btest(iornq,12)) 
c     *                              .and. ivoff.eq.0) then
            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
              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
c                  ivoff = -1
                  ivoffinc = -1
                else
c                  ivoff = 1
                  ivoffinc = 1
                end if
                if (((stemup      .and. nolev.ge.ncm-2) .or. 
     *              (.not.stemup .and. nolev.le.ncm+2)) .and.
c     *                mod(abs(ncm-nolev),2).eq.0) ivoff = 2*ivoff
     *                mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
                ivoff = ivoff+ivoffinc
              end if
            end if
            if (listslur .eq. 511) then
              print*,'You defined the tenth slur, one too many!'
              stop
            end if
c  
c  Get index of next slur not in use, starting from 8 down 
c
            ndxslur = log2(511-listslur)
c
c  Record slur index
c
            listslur = ibset(listslur,ndxslur)
c
c  Save for use on termination
c
            call setbits(isdata,4,28,ndxslur)
c
c  Shift for stem?
c
            if (stemup .and. slurudq.eq.'u') 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) ihoff = ihoff+8
c
c  (already shifted if stemup and slurudq='u')
c
              end if
            end if
            if (iscrd) then
c
c  Shift slur starts for chord? 
c
c              if (nolevs.gt.minlev .and. slurudq.eq.'d') then
c                ivoff = ivoff+1
c                ihoff = ihoff+8
c              else if (nolevs.lt.maxlev .and. slurudq.eq.'u') then 
c                ivoff = ivoff-1
c                if (.not.stemup) ihoff = ihoff+8
c              end if
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 = char(92)//'islur'//slurudq
              lnote = 7
            else
              notexq = char(92)//'is'//slurudq
              lnote = 4
            end if
c
c  Add slur index to string
c
            notexq = notexq(1:lnote)//char(48+ndxslur)
            lnote = lnote+1
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'//
     *                  char(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)
          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),3,0) .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)
                  if (btest(isdat1(j),27)) slurudq = 'u'
                  go to 4
                end if
              end if
3           continue
            print*,'Bad place in doslur'
            stop 1
4           continue
c
c  Shift slur ending for stem on any note?
c
            if (.not.stemup .and. slurudq.eq.'d') ihoff = ihoff-8
            if (btest(isdat2(isdat),3)) then
c
c  Shift ending for tie spacing
c
              if (slurudq .eq. 'u') then
                ihoff = ihoff-8
                ivoff = ivoff-1
              else if (slurudq .eq. 'd') then
                ivoff = ivoff+1
                if (stemup) ihoff = ihoff-8
              end if
            end if
            if (iscrd) then
c
c  Shift for chord?
c
c              if (nolevs.lt.maxlev .and. slurudq.eq.'u') then
c                ihoff = ihoff-8
c                ivoff = ivoff-1
c              else if (nolevs.gt.minlev .and.  slurudq.eq.'d') then
c                ivoff = ivoff+1
c                if (stemup) ihoff = ihoff-8
c              end if
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 = char(92)//'tslur'
              lnote = 6
            else
c
c  Shift needed
c
              notexq = char(92)//'ts'
              lnote = 3
            end if
            notexq = notexq(1:lnote)//char(48+ndxslur) 
            lnote = lnote+1
            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
              if ((stemup .and. slurudq.eq.'d') .or. 
     *                 (.not.stemup .and. slurudq.eq.'u')) then
                if (stemup) then
                  ivoffinc = -1
                else
                  ivoffinc = 1
                end if
                if (((stemup .and. nolev.ge.ncm-2) .or. 
     *              (.not.stemup .and. nolev.le.ncm+2)) .and.
     *               mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
              end if
              ivoff = ivoff+ivoffinc
            end if
            if (idcode.eq.1 .and. tmove) then
c
c  t-slur height adjustment
c
              iupdn = 1
              if (slurudq .eq. 'd') iupdn = -1
            end if
            call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
            if (slurudq.eq.'u' .and. 
     *           (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
              islhgt = nolevs+iupdn+ivoff 
c
c  If topvoice, upslur, and idcode checks, no more need to keep hgt for barno.
c
              if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then
                if (idcode .eq. is2n1) is1n1=0
              end if
            end if
            notexq = notexq(1:lnote)//noteq(1:lnoten)
            lnote = lnote+lnoten
            if (ihoff .ne. 0) then
              shift = ihoff*0.1
              notexq = notexq(1:lnote)//'{'
              lnote = lnote+1
              lform = lfmt1(shift)
              write(notexq(lnote+1:lnote+lform),
     *            '(f'//char(48+lform)//'.1)')shift
              lnote = lnote+lform
              notexq = notexq(1:lnote)//'}'
              lnote = lnote+1
            end if
            call addstr(notexq,lnote,soutq,lsout)
c
c  Clear the bit from list of slurs in use
c
            listslur = ibclr(listslur,ndxslur)
c
c  Zero out the entire strings for start and stop
c
            isdata = 0
            isdat2(isdat) = 0
            isdat1(j) = 0
            isdat2(j) = 0
          end if
          isdat1(isdat) = isdata 
        end if
1     continue
c
c  Clear and collapse the slur data list
c
      numdrop = 0
c      call report(nsdat,isdat1,isdat2)
      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)
          isdat1(isdat) = 0
          isdat2(isdat) = 0
        end if    
2     continue
      nsdat = nsdat-numdrop
c      call report(nsdat,isdat1,isdat2)
      return
      end
      subroutine addfb(nfb,iv,itnew,it1fb,it2fb,ulfbq,ifbadd)
      parameter (nm=7)
      integer nfb(nm),it1fb(nm,20),it2fb(nm,20)
      character*1 ulfbq(nm,20)
        ifbadd = 1
        nfb(iv) = nfb(iv)+1
        do 1 ifb = nfb(iv)-1 , 1 , -1
          if (itnew .lt. it1fb(iv,ifb)) then
            it1fb(iv,ifb+1) = it1fb(iv,ifb)
            it2fb(iv,ifb+1) = it2fb(iv,ifb)
            ulfbq(iv,ifb+1) = ulfbq(iv,ifb)
          else
            ifbadd = ifb+1
            go to 2
          end if
1       continue
2       continue
        it1fb(iv,ifbadd) = itnew
        ulfbq(iv,ifbadd) = 'x'
      return
      end
      subroutine addasx(ip,iv,wasxn,elasxn,fixednew,scaldold,isuxsp)
      parameter (nm=7)
      logical isuxsp
      common /comas1/ naskb,itask(20),wask(20),elask(20),iasxb,
     *                nasxb,ipasx(20),ivasx(20),wasx(20),elasx(20)
      common /comudsp/udsp(25),itudsp(25),nudsp,udoff(nm,20),nudoff(nm),
     *                 uxsp(25),ivuxsp(25),ipuxsp(25),nuxsp
      if (isuxsp) then
c
c  Find which uxsp we're dealing with
c
        do 1 iuxsp = 1 , nuxsp
          if (ip.eq.ipuxsp(iuxsp) .and. iv.eq.ivuxsp(iuxsp)) go to 2
1       continue
        print*,'You should not BEEE here in addasx!'
        stop 1
2       continue
c
c  Fixednew and scaldold must not be changed, since uxsp's are already included 
c  in fsyst from pmxa, and uxsp don't involve scaled space (? implement in pmxa) 
c
        if (nasxb.gt.0 .and. ipasx(nasxb).eq.ip .and. 
     *         ivasx(nasxb).eq.iv) then 
c
c  Must add user-defined space to what's here already.  
c
          wasx(nasxb) = wasx(nasxb)+uxsp(iuxsp)
        else
c
c  This place has no other space.
c
          nasxb = nasxb+1
          ipasx(nasxb) = ip
          ivasx(nasxb) = iv
          wasx(nasxb) = uxsp(iuxsp)
          elasx(nasxb) = 0.
        end if
      else
c
c  Non-uxsp processing
c
        nasxb = nasxb+1
        ipasx(nasxb) = ip
        ivasx(nasxb) = iv
        wasx(nasxb) = wasxn
        elasx(nasxb) = elasxn
        fixednew = fixednew+wasxn
        scaldold = scaldold+elasxn
      end if
      return
      end
      subroutine addask(itaskn,waskn,elaskn,
     *                  fixednew,scaldold,itglp1,isudsp)
      parameter (nm=7)
      logical isudsp
      common /comas1/ naskb,itask(20),wask(20),elask(20),iasxb,
     *                nasxb,ipasx(20),ivasx(20),wasx(20),elasx(20)
      common /comudsp/udsp(25),itudsp(25),nudsp,udoff(nm,20),nudoff(nm),
     *                 uxsp(25),ivuxsp(25),ipuxsp(25),nuxsp
      if (isudsp) then
c
c  Find which udsp we're dealing with
c
        do 1 iudsp = 1 , nudsp
          if (itaskn+itglp1 .eq. itudsp(iudsp)) go to 2
1       continue
        print*,'You should note BEEE here in addask!'
        stop 1
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. itaskn.eq.itask(naskb)) 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
          itask(naskb) = itaskn
          wask(naskb) = udsp(iudsp)
          elask(naskb) = 0.
        end if
      else
c
c  This is a normal space, no effect if smaller than existing space
c
        if (naskb.gt.0 .and. itaskn.eq.itask(naskb)) then
c
c  We already put in some space at this time
c  Check if new one needs more space than old one at same time
c
          if (waskn .gt. wask(naskb)) then
            naskb = naskb-1
          else
            return
          end if
        end if
        naskb = naskb+1
        itask(naskb) = itaskn
        wask(naskb) = waskn
        elask(naskb) = elaskn
        fixednew = fixednew+waskn
        scaldold = scaldold+elaskn
      end if
      return
      end
      subroutine askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0)
      logical figbass,ispoi,topmods,istype0,done
      common /comhsp/ hpttot(176)
      common /compoi/ ispoi
      common /comas3/ ask(1000),iask,asx(200),iasx,topmods
      character*40 pathnameq
      character*24 basenameq
      character*1 sq
      character*129 outq
      sq = char(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 (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
      iasx = 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
c
c  Now same deal for asx's
c
6     indxasx = index(outq,sq//'asx')
      if (indxasx .ne. 0) then 
        iasx = iasx+1
        call putast(asx(iasx),indxasx,outq)
        go to 6
      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         write(12,'(a)')outq(1:lenout)//'%'
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
      function llen(strq,n)
c        character strq
        character*129 strq
        do 1 llen = n , 0 , -1
          if (strq(llen:llen) .ne. ' ') return
1       continue
      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:)
c       write(outq(indxask+3:),fmtq)'t{',dim(elask,0.)
        write(outq(indxask+3:),fmtq)'t{',elask
        outq = outq(1:indxask+4+lp)//'}'//tag
      return
      end
      logical function blkstart(list,in,itstart,nodurm1)
      integer list(4,200)
        blkstart = itstart.eq.list(3,in) .and. 
     *             (in.eq.1 .or. nodurm1.ne.0) 
      return
      end
      subroutine sslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,nsdat,
     *                 notcrd,nolev)
c
c  Reads in slur data.  Record all h/v-shifts for non-chords, user-specified 
cc  ones for chords.  Auto-shifts in chords done after last crd note, in slurcrd
c  ones for chords.  
c
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      integer*4 isdat1(202),isdat2(202)
      logical invoff,turnon,notcrd
      character*128 lineq
      character*1 durq,dumq
      invoff = .false.
      turnon = .true.
      ivoff = 0
      ihoff = 0
      nsdat = nsdat+1
      call setbits(isdat1(nsdat),3,0,iv)  
      call setbits(isdat1(nsdat),1,12,kv-1)  
      call setbits(isdat1(nsdat),8,3,ip)  
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('uldt+- ',durq) .gt. 0) then
c
c  Null id
c
          idcode = 32
          iccount = iccount-1
        else
          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. iand(7,isdat1(isdat)) .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
        if (.not.invoff) then
c
c  Vertical offset 
c
          invoff = .true.
          iccount = iccount+1
          call readnum(lineq,iccount,dumq,fnum)
          iccount = iccount-1
          ivoff = int(fnum+.5)
          if (durq .eq. '-') ivoff = -ivoff
        else
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
        end if
        go to 1
      else if (durq .eq. 't') then
        isdat2(nsdat) = ibset(isdat2(nsdat),3)
        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
c      print*
c      print*,'In sslur'
c      call report(nsdat,isdat1,isdat2)
      return
      end
      subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,
c    *                  islope,smed,nolev1,nornb,epns)
     *                  islope,smed,nolev1,epns)
c
c The outer combo algorithm
c
      parameter (nm=7)
            common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      character*1 accq,ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,isxtup,btest,
     *        isfig,vxtup,inxtup,l1ng,l2ng,bar1syst,endxtup,xtended
      real*4 slope(800),xelsk(24)
c     integer ipb(24),nornb(nm)
      integer ipb(24)
      common /comask/ bar1syst,fixednew,scaldold,apt,abigpt,
     *                wheadpt,fbar,poenom
      common /comas1/ naskb,itask(20),wask(20),elask(20),iasxb,
     *                nasxb,ipasx(20),ivasx(20),wasx(20),elasx(20)
      common /comxtup/ xtupfac(nm),n2xtup(20),ixtup,vxtup(nm),inxtup,
     *                 ntupv(nm),nole11,islo11,xels11(24),eloff
      common /combmh/ bmhgt,clefend
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
        ibc = ibmcnt(ivx)
        n1 = iand(255,ipl(ivx,ibm1(ivx,ibc)))
        n2 = iand(255,ipl(ivx,ibm2(ivx,ibc)))
c
c Figure how many elemskips to each note. Use the list, counting only non-rests.
c
        elsksum = 0.
        iiasxb = iasxb
        nnb = 0
        sumx = 0.
        sumy = 0.
        isxtup = .false.
        endxtup = .false.
        do 2 in = n1, n2
          if (list(1,in).eq.ivx .and. 
     *         .not.btest(irest(ivx,list(2,in)),0)) then
            nnb = nnb+1
            ipb(nnb) = list(2,in)
            xelsk(nnb) = elsksum
            sumx = sumx+xelsk(nnb)
            sumy = sumy+nolev(ivx,ipb(nnb))
          end if
          if (in .lt. n2) then
            if (endxtup) then
              if (list(1,in) .ne. ivx) go to 2
              endxtup = .false.
            end if
c
c  Don't do anything until coming to next note in main voice.
c           
            if (nodur(ivx,ipb(nnb)) .gt. 0) then
c
c  Non-xtup or last note of xtup.
c
              if (.not.isxtup) then
                if (list(4,in).ne.0) then
                  elsperns = 
     *                  feon(float(list(4,in)))*xtupfac(ivx)
                end if
              else
c
c  Last note of xtup. Set flag so no more skips until next note in same voice. 
c
                endxtup = .true.
                eloff = (xelsk(nnb)-eloff)/2.
              end if
            else
c
c  Since nodur=0, this is start or middle of xtup
c
              if (.not.isxtup) then
c
c  Start of xtup
c
                isxtup = .true.
c
c  Save xelsk for number location computation. Won't work if >1 xtup at once?
c
                eloff = xelsk(nnb)
                xtended = .false.
                do 1 iin = in+1 , 100
                  if (.not.xtended .and. list(1,iin).eq.ivx) then
                    if (nodur(ivx,list(2,iin)).gt.0) then
                      xtended = .true.
                      iip = list(2,iin)
                      if (list(4,iin).gt.0) go to 3
                    end if
                  else if (xtended) then
                    if (list(4,iin).gt.0) go to 3
                  end if
1               continue
                print*,'Trouble.  Call Dr. Don!'
                stop
3               continue
c
c At this point iip is ip# of last note of xtup, and iin is last list pos'n
c   before jump to next time position (sets nspace)
c
c  xtupfac may not be defined if xtup doesn't start the beam?
c
                if (nnb .eq. 1) then
c                
c  Xtup starts the beam
c
c                 elsperns = feon(float(nodur(ivx,iip)))*xtupfac(ivx)
                  elsperns = feon(float(list(4,iin)))*xtupfac(ivx)
                else
c
c  *Assumes* that xtup defines spacing!
c
                  elsperns = 
     *                  feon(float(nodur(ivx,iip))/(iip-ipb(nnb)+1))
                end if
              end if
            end if  
            if (list(4,in).gt.0 .or. isxtup) then
              elsksum = elsksum+elsperns
c
c  Add in space for for skips if needed
c
              if (isxtup .and. iiasxb.le.nasxb .and. 
     *          list(2,in)+1.eq.ipasx(iiasxb) .and. 
     *                     list(1,in).eq.ivasx(iiasxb)) then
c
c  add in approximate space for xtup accid skip
c
                elsksum = elsksum+wasx(iiasxb)/poenom-elasx(iiasxb)
                iiasxb = iiasxb+1
              end if
ccccccccccccccccccccccccccccccccc
c
c  Insert check for ask here ???.
c
ccccccccccccccccccccccccccccccccc
              if (endxtup) isxtup=.false.
            end if
          end if
2       continue
        if (ipb(nnb) .gt. 1) then 
          if (nodur(ivx,ipb(nnb)-1).eq.0) eloff = (xelsk(nnb)-eloff)/2.
        end if  
        epns = elsperns
        smed = 0.
        if (.not.btest(islur(ivx,ipb(1)),2)) then
c
c No forced 0 slope
c
          if (nnb .eq. 1) go to 6
          nsc = 0
          do 5 inb = 1 , nnb-1
          do 5 jnb = inb+1 , nnb
            nsc = nsc+1
            slope(nsc) = (nolev(ivx,ipb(jnb))-nolev(ivx,ipb(inb)))/
     *                   (xelsk(jnb)-xelsk(inb))
            if (abs(slope(nsc)) .lt. 1.e-4) then
              nsc = nsc+1
              slope(nsc) = slope(nsc-1)
              nsc = nsc+1
              slope(nsc) = slope(nsc-1)
            end if
5         continue
          if (nsc .eq. 1) then
            smed = slope(1)
            go to 6
          end if
          nscmid = nsc/2+1
          do 7 i = 1 , nscmid
            do 7 j = i+1 , nsc
              if (slope(j) .lt. slope(i)) then
                t = slope(j)
                slope(j) = slope(i)
                slope(i) = t
              end if
7         continue
          smed = slope(nscmid)
          if (nsc .eq. 2*(nsc/2) .and. 
     *        abs(slope(nscmid-1)) .lt. abs(slope(nscmid)))
     *        smed=slope(nscmid-1)
6         continue
          islope = ni(0.5*smed*slfac)
          if (iabs(islope) .gt. 9) islope = isign(9,islope)
        else
          islope = 0
        end if
        beta = (sumy-islope/slfac*sumx)/nnb
        nolev1 = beta+.5
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+iul*(stemlen+bmhgt*(mult(ivx,ipb(1))-1))
        do 4 inb = 1 , nnb
          ybeam = yb1+islope*xelsk(inb)/slfac
     *              -iul*bmhgt*(mult(ivx,ipb(inb))-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
          nolev1 = ni(nolev1+iul*deficit)
          dnolev = nolev1-nolevo
          off1 = off1+dnolev
          off2 = off2+dnolev
        end if
        ssq = ssq+2*dnolev*(syb-sumy)+dnolev**2
        if (.not.vxtup(ivx) .and. sqrt(ssq/nnb) .gt. stemmax .and. 
     *    (abs(off1).lt.stemmax .or. abs(off2).lt.stemmax)
     *    .and. .not.btest(islur(ivx,ipb(1)),2)) then
c
c  The first check is to save trouble of putting xtup's in setbm2.
c  The penultimate check is that first and last stems aren't both excessive.
c  The last check is that a 0 slope has not been forced
c
          call setbm2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1)
        end if
c 
c  Check if beam starts or ends too high or low.
c
        xboff = bmhgt*(mult(ivx,ipb(1))-1)
        l1ng = iul*(nolev1-ncmid(iv,ipb(1)))+xboff+7 .lt. 0.
        xnolev2 = nolev1+islope/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 = ni(ncmid(iv,ipb(1))-(7.+xboff)*iul)
          end if
          if (l2ng) then
            xnolev2 = ni(ncmid(iv,ipb(nnb))-(7.+xboff)*iul)
          end if
c
c  Since one or the other end has changed, need to change slope
c
          if (.not.btest(islur(ivx,ipb(1)),2)) 
     *       islope = ni(slfac*(xnolev2-nolev1)/xelsk(nnb))
        end if
      return
      end
      subroutine setbm2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1)
c
c The MEAN SQUARE slope algorithm
c
      parameter (nm=7)
            common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*1 accq,ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,
     *        isfig
      real*4 xelsk(24)
      integer ipb(24)
        ibc = ibmcnt(ivx)
        n1 = iand(255,ipl(ivx,ibm1(ivx,ibc)))
        n2 = iand(255,ipl(ivx,ibm2(ivx,ibc)))
        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 = ni(0.5*em*slfac)
        if (iabs(islope) .gt. 9) islope = isign(9,islope)
        beta = (sumy-islope/slfac*sumx)/nnb
        nolev1 = beta+.5
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
          nolevo = nolev1
          nolev1 = ni(nolev1+iul*deficit)
        end if
      return
      end
      block data
      character*6 nstartq(15)
      common /comstart/ nstartq,lstart(15),facmtr
      character*60 instrq,titleq,compoq
      logical headlog
      common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
     *    inhead,inbothd
      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
      data gslfac /9./
      data nstartq /'notss ','dummy ','notes ','notesp','Notes ',
     *              'Notesp','NOtes ','NOtesp','NOTes ','NOTesp',
     *              'NOTEs ','NOTEsp','NOTES ','NOTESp','NOTEZ '/
      data lstart /5,5,5,6,5,6,5,6,5,6,5,6,5,6,5/
      data instrq,titleq,compoq,headlog /3*' ',.false./
c
c  meter space (pts) = xb4mbr = musicsize*facmtr
c
      data facmtr /0.7/
      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.3 /
      end
      function ncmid(iv,ip)
      parameter (nm=7)
            common /all/ mult(nm,200),jv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      character*1 accq,ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,isfig
      common /comcc/ ncc(nm),itcc(nm,10),ncmidcc(nm,10),
     *               ndotmv(nm),updot(nm,20),rtdot(nm,20)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
        if (ncc(iv) .eq. 1) then
          ncmid = ncmidcc(iv,1)
        else
          itime = list(3,iand(255,ipl(ivx,ip)))
          do 1 icc = ncc(iv) , 1 , -1
            if (itime .ge. itcc(iv,icc)) then
              ncmid = ncmidcc(iv,icc)
              return
            end if
1         continue
          print*,'Problem in ncmid()'
          stop
        end if
      end
c      subroutine defnotes(iemin,iemax)
      subroutine defnotes(ieneed)
c
c note  64 .64  32 .32  16 .16  8  .8   4   .4   2  .2   0  .0  00
c index 1   2   3   4   5   6   7   8   9   10  11  12  13  14  15
c time  1   x   2   3   4   6   8   12  16  24  32  48  64  96 128 
c
      character*79 notexq
      character*6 nstartq(15)
      logical btest
      common /comstart/ nstartq,lstart(15),facmtr
      do 2 index = 1 , 15 
        if (btest(ieneed,index)) then
          if (mod(index,2) .eq. 1) then
            time = float(2**((index-1)/2))
          else
            time = 0.75*float(2**(index/2))
          end if
          notexq = char(92)//'def'//char(92)//nstartq(index)
          lnote = 5+lstart(index)
          notexq = notexq(1:lnote)//'{'//char(92)//'vnotes'
          lnote = lnote+12
          write(notexq(lnote-3:lnote),'(f4.2)')feon(time)
          write(11,'(a)')notexq(1:lnote)//char(92)//'elemskip}%'
        end if
2     continue
      return
      end
      subroutine clefsym(isl,notexq,lnote,nclef)
      character*(*) notexq
        nclef = iand(ishft(isl,-12),7)
        if (nclef .eq. 0) then
          nlev = 2
        else if (nclef .lt. 5) then
          nlev = 2*nclef-2
        else
          nlev = 2*nclef-6
        end if
        notexq = char(92)//'pmxclef'//char(48+nclef)//char(48+nlev)
        lnote = 10
      return
      end
c     character*2 function acsymq(accq)
      subroutine accsym(accq,acsymq,lacc)
      character*1 accq
      character*3 acsymq
      if (accq .eq. 'f' .or. accq .eq. 'F') then
        acsymq = 'fl'
        lacc = 2
      else if (accq .eq. 's' .or. accq .eq. 'S') then
        acsymq = 'sh'
        lacc = 2
      else if (accq .eq. 'n' .or. accq .eq. 'N') then
        acsymq = 'na'
        lacc = 2
      else if (accq .eq. 'g' .or. accq .eq. 'G') then
        acsymq = 'dfl'
        lacc = 3
      else if (accq .eq. 't' .or. accq .eq. 'T') then
        acsymq = 'dsh'
        lacc = 3
      else
        print*,'bad accidental: ',accq 
c        stop
      end if 
      return
      end 
      subroutine littex(islur,nnl,iv,topmods,lineq,iccount)
      parameter (nm=7)
      integer islur(nm,200)
      logical topmods
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),aftshft,
     *                nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
     *                noffseg,ngrace,nvolt,ivlit(36),iplit(36),nlit,
     *                lenlit(36),multg(37),upg(37),slurg(37),slashg(37),
     *                accgq(74),voltxtq(6),litq(36)
      logical upg,slurg,slashg
      character*128 lineq,litq
      character*10 voltxtq
      character*1 accgq,durq
      nlit = nlit+1
      ivlit(nlit) = iv
      iplit(nlit) = nnl
      itype = 1
17    call getchar(lineq,iccount,durq)
      if (durq .eq. char(92)) then
        itype=itype+1
        go to 17
      end if
      litq(nlit) = char(92)//durq
      lenlit(nlit) = 2
18    call getchar(lineq,iccount,durq)
      if (durq.eq.char(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))//char(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)
      else
        if (itype .eq. 3) then
c
c  Write the string NOW
c
          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         write(16,'(a)')litq(nlit)(1:lenlit(nlit))
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
      subroutine putfig(ifig,offnsk,figcheck,soutq,lsout)
      common /comfig/ itfig(74),figqq(74),nfigs
      character*6 figqq,figq
      character*80 soutq,notexq
      character*1 ch1q,ch2q,sq
      character*2 nofq,nofaq
      logical figcheck
        sq = char(92)          
        if (abs(offnsk) .gt. .0001) then
c
c  Write offset for floating figure, to two decimal places
c
          notexq = sq//'off{'
c          if (-offnsk .lt. -9.95) then
c            write(notexq(6:10),'(f5.1)')-offnsk
c            lnote = 10
c          else if (-offnsk.lt.-.95 .or. -offnsk.gt.9.95) then
c            write(notexq(6:9),'(f4.1)')-offnsk
c            lnote = 9
c          else if (-offnsk.lt.-.001 .or. -offnsk.gt..95) then
c            write(notexq(6:8),'(f3.1)')-offnsk
c            lnote = 8
c          else
c            write(notexq(6:7),'(f2.1)')-offnsk
c            lnote = 7
          if (-offnsk .lt. -9.995) then
            write(notexq(6:11),'(f6.2)')-offnsk
            lnote = 11
          else if (-offnsk.lt.-.995 .or. -offnsk.gt.9.995) then
            write(notexq(6:10),'(f5.2)')-offnsk
            lnote = 10
          else if (-offnsk.lt.-.0001 .or. -offnsk.gt..995) then
            write(notexq(6:9),'(f4.2)')-offnsk
            lnote = 9
          else
            write(notexq(6:8),'(f3.2)')-offnsk
            lnote = 8
          end if
          notexq = notexq(1:lnote)//sq//'noteskip}'
          call addstr(notexq,lnote+10,soutq,lsout)
        end if
        figq = figqq(ifig)
        ic = 1
        nof = 0
        nofa = -1
c
c  Beginning of loop
c
1       ch1q = figq(ic:ic)
c
c  Exit when first blank is encountered
c
        if (ch1q .eq. ' ') go to 2
c
c  Just starting or not yet finished.  Set up vertical offset.
c
        lnof = 1
        nofq = char(nof+48)
        if (nof .gt. 9) then
          lnof = 2
          nofq = '1'//char(nof-10+48)
        end if
        if (nofa .eq.-1) then
          lnofa = 2
          nofaq = '-1'
        else if (nofa .lt. 10) then
          lnofa = 1
          nofaq = char(nofa+48)
        else
          lnofa = 2
          nofaq = '1'//char(nofa+38)
        end if
        if (ch1q .eq. '0') then
c
c  Continuation figure.  Next digit is length (in noteskips)
c
          ic = ic+1
          ch2q = figq(ic:ic)
          call addstr(sq//'Cont{'//nofq(1:lnof)//'}{'//ch2q//'}',
     *           10+lnof,soutq,lsout)      
        else if (ch1q.eq.'#'.or.ch1q.eq.'-'.or.ch1q.eq.'n') then
          ic = ic+1
          ch2q = figq(ic:ic)
          if (ch2q .eq. ' ') then
c
c  Figure is a stand-alone accidental, so must be centered
c
            if (ch1q .eq. '#') then
              call addstr(sq//'Figu{'//nofaq(1:lnofa)//
     *          '}{'//sq//'sharpfig}',18+lnofa,soutq,lsout)
            else if (ch1q .eq. '-') then
              call addstr(sq//'Figu{'//nofaq(1:lnofa)//
     *          '}{'//sq//'flatfig}',17+lnofa,soutq,lsout)
            else if (ch1q .eq. 'n') then
              call addstr(sq//'Figu{'//nofaq(1:lnofa)//
     *                '}{'//sq//'natfig}',16+lnofa,soutq,lsout)
            end if
            go to 2
          else 
c
c  Figure is an accidental followed by a number
c  First put the accidental (offset to the left)
c
            if (ch1q .eq. '#') then
              call addstr(sq//'Figu{'//
     *               nofaq(1:lnofa)//'}{'//sq//'fsmsh}',
     *               15+lnofa,soutq,lsout)      
            else if (ch1q .eq. '-') then
              call addstr(sq//'Figu{'//
     *               nofaq(1:lnofa)//'}{'//sq//'fsmfl}',
     *               15+lnofa,soutq,lsout)      
            else if (ch1q .eq. 'n') then
              call addstr(sq//'Figu{'//
     *               nofaq(1:lnofa)//'}{'//sq//'fsmna}',
     *               15+lnofa,soutq,lsout)      
            end if
c
c  Now put the number
c
            call addstr(sq//'Figu{'//nofq(1:lnof)//'}{'//ch2q//'}',
     *           10+lnof,soutq,lsout)      
          endif
        else if (ch1q .eq. '_') then
c
c  Placeholder only (for lowering a figure).  Don't do anything!
c
c          call addstr(sq//'Figu{'//nofq(1:lnof)//'}{ }',
c     *           10+lnof,soutq,lsout)      
          continue
        else
c
c  Figure is a single number
c
          call addstr(sq//'Figu{'//nofq(1:lnof)//'}{'//ch1q//'}',
     *           10+lnof,soutq,lsout)      
        end if
        if (ic .ge. 6) go to 2
        ic = ic+1
        nof = nof+4
        nofa = nofa+4  
        go to 1
2     continue
      if (abs(offnsk) .gt. .0001) then
        notexq = sq//'off{'
c        if (offnsk .lt. -9.95) then
c          write(notexq(6:10),'(f5.1)')offnsk
c          lnote = 10
c        else if (offnsk.lt.-.95 .or. offnsk.gt.9.95) then
c          write(notexq(6:9),'(f4.1)')offnsk
c          lnote = 9
c        else if (offnsk.lt.-.001 .or. offnsk.gt..95) then
c          write(notexq(6:8),'(f3.1)')offnsk
c          lnote = 8
c        else
c          write(notexq(6:7),'(f2.1)')offnsk
c          lnote = 7
        if (offnsk .lt. -9.995) then
          write(notexq(6:11),'(f6.2)')offnsk
          lnote = 11
        else if (offnsk.lt.-.995 .or. offnsk.gt.9.995) then
          write(notexq(6:10),'(f5.2)')offnsk
          lnote = 10
        else if (offnsk.lt.-.0001 .or. offnsk.gt..995) then
          write(notexq(6:9),'(f4.2)')offnsk
          lnote = 9
        else
          write(notexq(6:8),'(f3.2)')offnsk
          lnote = 8
        end if
        notexq = notexq(1:lnote)//sq//'noteskip}'
        call addstr(notexq,lnote+10,soutq,lsout)
      end if
      if (ifig .lt. nfigs) then
        ifig = ifig+1
      else
        nfigs=0
        figcheck = .false.
      end if
      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 readmeter(lineq,iccount,mtrnum,mtrden)
      character*128 lineq
      character*1 durq
      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'//char(48+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'//char(48+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. 

      character*128 lineq
      character*1 durq
      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'
        stop
      end if
      icf = i2-i1+49
      read(lineq(i1:i2),'(f'//char(icf)//'.0)')fnum
      return
      end
      subroutine dotrill(iv,ip,iornq,noteq,lnoten,notexq,lnote)
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      character*8 noteq
      character*79 notexq
      logical tronly,btest 
      do 1 itr = 1 , ntrill
        if (iv.eq.ivtrill(itr) .and. ip.eq.iptrill(itr)) go to 2
1     continue
      print*,'Problem in dotrill.  Call Dr. Don'
      stop
2     continue
      tronly = xnsktr(itr) .lt. 0.01
      if (tronly) then
        notexq = char(92)//'zcharnote'
        lnote = 10
c     else if (ornq .eq. 'T') then
c  Bits 1-13: stmgx+Tupf._)  14: Down fermata, was F  15: Trill w/o "tr", was U
      else if (btest(iornq,7)) then
        notexq = char(92)//'Trille'
        lnote = 7
      else
        notexq = char(92)//'trille'
        lnote = 7
      end if
      notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
      lnote = lnote+lnoten+1
c
c  Write trill duration to nearest tenth of a noteskip
c
      if (tronly) then
        notexq = notexq(1:lnote)//char(92)//'it tr}'
        lnote = lnote+7
        return
      end if
      if (xnsktr(itr) .lt. .95) then
        nfmt = 2
      else if (xnsktr(itr) .lt. 9.95) then
        nfmt = 3
      else
        nfmt = 4
      end if
      write(notexq(lnote+1:lnote+nfmt),'(f'//char(48+nfmt)//'.1)')
     *   xnsktr(itr)
      lnote = lnote+nfmt
      notexq = notexq(1:lnote)//'}'
      lnote = lnote+1
      return
      end
      subroutine docrd(ivx,ip,nodu,ncm,iv,itnow,soutq,lsout,ulq,ibmcnt,
     *                 islur,nvmx,nv,beamon,nolevm,ihornb,nornb,stemlen)
      parameter (nm=7)
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      logical lowdot
      integer*4 ihornb(nm,24),nornb(nm)
      character*1 ulq(nm,8)
      character*4 nosymq
      character*8 noteq
      character*13 accstrq 
      character*79 notexq,outq
      character*80 soutq
      logical btest,isleft,isright,beamon
      data accstrq /'naflshdfl dsh'/
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
      do 5 icrd = icrd1 , icrd2
        lnote = 0
        nolev = iand(ishft(icrdat(icrd),-12),127)
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)
            end if
          end if
        end if
        if (btest(icrdat(icrd),26)) then
c
c  Move the dot. 
c
          updotc = 0.1*(iand(127,icrdot(icrd))-64)
          rtdotc = 0.1*(iand(127,ishft(icrdot(icrd),-7))-64)
          call dotmov(updotc,rtdotc,soutq,lsout)
        end if
        isleft = btest(icrdat(icrd),23)
        isright = btest(icrdat(icrd),24)
c
c  Check for ornament in chord.
c
        if (icrdorn(icrd) .gt. 0) then
          call putorn(icrdorn(icrd),nolev,nolevm,nodu,nornb,ulq,
     *         ibmcnt,ivx,ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,
     *         ip,0,beamon,.true.)
c
c     subroutin putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx,
c    *     ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,ip,islhgt,
c    *     notcrd,beamon,iscrd)
c
          call addstr(outq,lout,soutq,lsout)
        end if
c
c  Get first letters in chord-note symbol
c
        if (isleft) then
          nosymq = char(92)//'l'     
        else if (isright) then
          nosymq = char(92)//'r'
        else
          nosymq = char(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) then
          lsym = 3
        else
          nosymq = nosymq(1:3)//'p'
          lsym = 4
        end if 
c
c  Check for accidental
c
        if (btest(icrdat(icrd),19)) then
c
c  Get note name
c
          call notefq(noteq,lnoten,nolev,ncm)
          if (lnoten.eq.1) call addblank(noteq,lnoten)
          iacc = iand(7,ishft(icrdat(icrd),-20))-1
          if (iacc .lt. 3) then
            lacc = 2
          else
            iacc = 2*iacc-7
            lacc = 3
          end if
          iacc = iacc*2+1
          i2acc = iacc+lacc-1
          notexq = char(92)//accstrq(iacc:i2acc)
     *            //noteq(1:lnoten)//nosymq
          lnote = 1+lacc+lnoten
        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(itnow,iv,nolev,ncm,soutq,lsout)
        end if
        call addstr(notexq,lnote,soutq,lsout)
5     continue
      return
      end
      subroutine dograce(ivx,ip,ptgr,soutq,lsout,ncm,acciq,ig,ipl,
     *  farend)
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=7)
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),aftshft,
     *                nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
     *                noffseg,ngrace,nvolt,ivlit(36),iplit(36),nlit,
     *                lenlit(36),multg(37),upg(37),slurg(37),slashg(37),
     *                accgq(74),voltxtq(6),litq(36)
      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,apt,abigpt,
     *                wheadpt,fbar,poenom
c      common /comslur/ listslur,ndxslur(nm,2),upslur(nm,2)
      common /comslur/ listslur,upslur(nm,2),ndxslur
      common /comoct/ noctup
      logical upg,slurg,slashg,bar1syst,upslur,btest,isgaft,iswaft,
     *        normsp,farend
      real*4 ptgr(37)
      character*80 soutq
      character*128 litq
      character*79 notexq
      character*10 voltxtq
      character*8 noteq
      character*3 acsymq
      character*1 accgq,acciq,sq
      sq = char(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
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. 511) then
          print*,'You defined the tenth slur, one too many!'
          stop 1
        end if
c  
c  Slur on fore-grace.  Get index of next slur not in use, starting from 8 down.  
c
        ndxslur = log2(511-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 = ni(ptgr(ig))
          if (niptgr .lt. 10) then
            call addstr(char(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 (accgq(ngstrt(ig)).ne.'x') 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 (upg(ig)) then
            call addstr(sq//'islurd',7,soutq,lsout)
          else
            call addstr(sq//'isluru',7,soutq,lsout)
          end if
          call addstr(char(48+ndxslur)//noteq(1:lnoten),1+lnoten,
     *                 soutq,lsout)
        end if
        if (accgq(ngs) .ne. 'x') then
          call notefq(noteq,lnoten,nolevg(ngs),ncm)
          if (lnoten .eq. 1) call addblank(noteq,lnoten)
          call accsym(accgq(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)
        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,4,23)
          call notefq(noteq,lnoten,nolevg(ngs),ncm)
          call addstr(sq//'tslur',6,soutq,lsout)
          call addstr(char(48+ndxslur)//noteq(1:lnoten),
     *              1+lnoten,soutq,lsout)
          slurg(ig) = .false.
          listslur = ibclr(listslur,ndxslur)
        end if
        call addstr('}',1,soutq,lsout)
      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. accgq(ing).ne.'x') 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 = ni(0.5*em*gslfac)
        if (iabs(islope) .gt. 9) islope = isign(9,islope)
        beta = (sumy-islope/gslfac*sumx)/nng(ig)
        nolev1 = beta+.5
c
c  Back up
c
        notexq = sq//'tinynotesize'//sq//'off{'
        if (normsp) then
          write(notexq(19:23),'(a1,f4.1)')'-',ptgr(ig)
          call addstr(notexq(1:23)//'pt}',26,soutq,lsout)
        else
          aftshft = wheadpt*1.33
          if (accgq(ngstrt(ig)).ne.'x') aftshft = aftshft+wheadpt*0.5
          write(notexq(19:22),'(f4.1)')aftshft
          call addstr(notexq(1:22)//'pt}'//sq//'bsk',29,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(char(48+islope),1,soutq,lsout)
        else
          call addstr('{-'//char(48-islope)//'}',4,soutq,lsout)
        end if
c
c  Start a slur on fore-grace
c
        if (slurg(ig) .and. .not.isgaft .and. .not.iswaft) then
          call notefq(noteq,lnoten,nolevg(ngs),ncm)
          if (upg(ig)) then
            call addstr(sq//'islurd',7,soutq,lsout)
          else
            call addstr(sq//'isluru',7,soutq,lsout)
          end if
          call addstr(char(48+ndxslur)//noteq(1:lnoten),1+lnoten,
     *                 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 (accgq(ngs) .eq. 'x') then
          notexq = sq//'zqb0'//noteq(1:lnoten)
          lnote = 5+lnoten
        else
          if (lnoten .eq. 1) call addblank(noteq,lnoten)
          call accsym(accgq(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 = wheadpt*emgfac
          if (accgq(ing).ne.'x') ptoff = ptoff+wheadpt*acgfac
          if (isgaft .and. .not.iswaft) aftshft = aftshft+ptoff
          notexq = sq//'off{'
          write(notexq(6:8),'(f3.1)')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
              if (iswaft) ndxslur = igetbits(ipl,4,23)
              call notefq(noteq,lnoten,nolevg(ing),ncm)
              call addstr(sq//'tslur',6,soutq,lsout)
              call addstr(char(48+ndxslur)//noteq(1:lnoten),
     *              1+lnoten,soutq,lsout)
c
c  Stop slur terminator after exit from this subroutine
c
              if (iswaft) listslur = ibclr(listslur,ndxslur)
              slurg(ig) = .false.
            end if
          end if
c
c  Accidental if needed
c
          if (accgq(ing).ne.'x') then
            call notefq(noteq,lnoten,nolevg(ing),ncm)
            if (lnoten .eq. 1) call addblank(noteq,lnoten)
            call accsym(accgq(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
        notexq = sq//'normalnotesize'//sq//'off{'
        lnote = 20
        ptoff = wheadpt*emgfac
        if (acciq .ne. 'x') ptoff = ptoff+wheadpt*accfac
c       if (isgaft) then
        if (isgaft .and. .not.iswaft) then
          notexq = notexq(1:20)//'-'
          lnote = 21
          ptoff = aftshft
        end if
        if (ptoff .lt. 9.95) then
c         write(notexq(21:23),'(f3.1)')ptoff
          write(notexq(lnote+1:lnote+3),'(f3.1)')ptoff
          lnote = lnote+3
        else
c         write(notexq(21:24),'(f4.1)')ptoff
          write(notexq(lnote+1:lnote+4),'(f4.1)')ptoff
          lnote = lnote+4
        end if
        call addstr(notexq(1:lnote)//'pt}',lnote+3,soutq,lsout)
        if (isgaft.and..not.iswaft) call addstr(sq//'sk',3,soutq,lsout)
      end if
      return
      end
      subroutine wsclef(iv,nv,noinst,clefq,nclef)
c
c  \setclef for instrument containing voice iv
c
      parameter (nm=7)
      common /comnvi/ nvi(nm)
      character*1 clefq(nm)
      character*20 temq
      clefq(iv) = char(48+nclef)
      if (noinst .gt. 0) then
c
c  The old way.  Only inst #1 can have >1 voice
c
        if (nv.eq.noinst .or. iv.gt.nv-noinst+1) then
          iinst = iv+noinst-nv
          iv1 = iv
          iv2 = iv
        else
          iinst = 1
          iv1 = 1
          iv2 = nv-noinst+1
        end if
      else
c
c  The new way.
c
        iv1 = 1
        do 1 iinst = 1 , -noinst
          if (iv .lt. iv1+nvi(iinst)) go to 2
          iv1 = iv1+nvi(iinst)
1       continue
        print*
        print*,'Should not be here in wsclef!'
        stop 1
2       continue
        iv2 = iv1+nvi(iinst)-1
      end if
      temq = char(92)//'setclef'//char(48+iinst)
      if (iv1 .eq. iv2) then
        write(11,'(a)')temq(1:9)//clefq(iv)//'%'
      else
        temq = temq(1:9)//'{'
        ltem = 10
        do 3 iiv = iv1 , iv2
          temq = temq(1:ltem)//char(48+numclef(clefq(iiv)))
          ltem = ltem+1
3       continue
        write(11,'(a)')temq(1:ltem)//'}%'
      end if
      return
      end
      subroutine endslur(stemup,upslur,nolev,iupdn,ndxslur,ivoff,ncm,
     *  soutq,lsout)
      logical shift,stemup,upslur
      character*80 soutq
      character*79 notexq
      character*8 noteq
      shift = .not.stemup .and. .not.upslur
      if (.not.shift) then
c
c  No shift needed
c
         notexq = char(92)//'tslur'
         lnote = 6
      else
c
c  Shift needed
c
         notexq = char(92)//'ts'
         lnote = 3
      end if
      notexq = notexq(1:lnote)//char(48+ndxslur)
      lnote = lnote+1
      call notefq(noteq,lnoten,nolev+iupdn+ivoff,ncm)
      notexq = notexq(1:lnote)//noteq(1:lnoten)
      lnote = lnote+lnoten
      if (shift) then
        notexq = notexq(1:lnote)//'{-.6}'
        lnote = lnote+5
      end if
      call addstr(notexq,lnote,soutq,lsout)
      return
      end
      subroutine getfig(itoff,charq,lineq,iccount,isfig,itfig,
     *   itsofar,nodur,figq,ivx,nfigs)
      logical isfig
      character*1 charq
      character*6 figq
      character*128 lineq
      if (ivx .ne. 1) then
c
c  Read past the figure
c
6       call getchar(lineq,iccount,charq)
        if (charq .ne. ' ') go to 6
        return
      end if
      nfigs = nfigs+1
      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)
      if (charq .ne. ' ') then
        figq = figq(1:lfig)//charq
        lfig = lfig+1
        go to 5
      end if
      return
      end
      subroutine eskb4(ip,ivx,in,ib,nspace,itstart,fbar,itrpt,esk)
c
c  Get elemskips to previous note.  Called only for graces, no xtups involved.
c
      parameter (nm=7)
            common /all/ mult(nm,200),iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   iornq(nm,200),isdat1(202),isdat2(202),nsdat
      character*1 accq,ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,isfig
      integer*4 nspace(20),itstart(20)
      itnd = list(3,in)
      if (ip.eq.1 .or. itnd.eq.itrpt) then
c
c  Start of bar or after rpt.
c
        esk = fbar
        return
      else
        esk = 0.
        itprev = itnd-nodur(ivx,ip-1)
        do 1 iib = ib , 1 , -1
          if (itstart(iib) .le. itprev) then
c
c  This is the block
c
            nnsk = (itnd-itprev)/nspace(iib)
            esk = esk+nnsk*feon(float(nspace(iib)))
            return
          else
            nnsk = (itnd-itstart(iib))/nspace(iib)
            esk = esk+nnsk*feon(float(nspace(iib)))
            itnd = itstart(iib)
          end if
1       continue
      end if
      print*,'Problem in eskb4.  Send files to Dr. Don'
      stop
      end
      subroutine putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx,
     *     ncm,islur,nvmx,nv,ihornb,stemlin,outq,lout,ip,islhgt,
     *     beamon,iscrd)
c
c  All args are individual array element *values* except nornb,ihornb,ulq.
c  notcrd = .true. if ornament is on main note.  
c    nolevm is level of main note (for chords)
c 
      parameter (nm=7)
      character*1 ulpzq,ulq(nm,8),udqq,sq
      character*8 noteq
      character*79 notexq,outq
      integer*4 ihornb(nm,24),nornb(nm)
      logical btest,iscrd,usebmht,beamon
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      sq = char(92)
      lout = 0
      usebmht = .false.
      if (nodur .lt. 64) then
        stemlen = stemlin
      else
        stemlen = 0.
      end if
c
c  Get up-downness. ulpzq is opposite from stem direction for both beams and 
c    non beams.  Can use in name of ornament [ . or _ ] 
c
      if (beamon) then
        if (ulq(ivx,ibmcnt) .eq. 'u') then
          ulpzq = 'l'
        else
          ulpzq = 'u'
        end if
      else
        if (udqq(nolevm,ncm,islur,nvmx,ivx,nv).eq.'l' ) then
          ulpzq = 'u'
        else
          ulpzq = 'l'
        end if
      end if
c
c  To enable >1 ornament on a note, next line is top of manual loop.
c
2     continue
c
c  Bit # of last ornament (last of bits 0-21)
c
      ibit = log2(iand(iornq,4194303))
      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: >
c
      if (btest(iornq,22)) then
c
c  Height is set by special beam stuff.  Following block leaves ihorn set for
c  later orns on same note.
c
        if (.not.usebmht) then
          ihorn = ihornb(ivx,nornb(ivx))
          if (iand(iornt,6144).gt.0) then
c
c  Fine-tune for _ or .  Note flaw: for later normal orn here, ht. is wrong.
c
            ihorn = ihorn+1-2*index('l',ulpzq)
            ulpzq = char(225-ichar(ulpzq))
          else if (ulpzq .eq. 'u') then
            ihorn = ihorn-2
          end if
          nornb(ivx) = nornb(ivx)+1
          usebmht = .true.
        end if
      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
c  Staccato . or tenuto _ , but not special beam stuff.  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-ni(stemlen)-3,ncm-6)
        end if
      else if (ulpzq.eq.'l') then
c
c  (iscrd and nolev=maxlev) or (.not.iscrd) 
c
        ihorn = max(nolev+stemlen+2,ncm+5.)
      else
        ihorn = max(nolev+2,ncm+5)
      end if
      ioff = 0
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,16)) then
        notexq = sq//'esharp'
        lnote = 7
        ioff = 2
      else if (btest(iornt,17)) then
        notexq = sq//'eflat'
        lnote = 6
        ioff = 1
      else if (btest(iornt,18)) then
        notexq = sq//'enat'
        lnote = 5
        ioff = 2
      else if (btest(iornt,19)) then
        notexq = sq//'usf'
        lnote = 4
        ioff = -2
      else if (btest(iornt,20)) then
        notexq = sq//'usfz'
        lnote = 5
        ioff = -2
       end if
c
c  User-defined level shift of ornament from default?
c
      if (btest(iornq,25)) then
c
c  Find which (if any) element of kudorn has the shift.
c
        do 3 iudorn = 1 , nudorn
          if (ip+ishft(ivx,8)+ishft(nolev,12)+ishft(ibit,19) .eq. 
     *         iand(33554431,kudorn(iudorn))) go to 4
3       continue
c
c  Nothing shifted on this note; exit this loop
c
        go to 5
4       continue
c        ioff = ioff+iand(63,ishft(kudorn(iudorn),-25))-32       
        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
cc   2.  No user-defined shift (btest(iornq,24))
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
c      if (iand(islur,15).gt.0 .and. .not.btest(iornq,24) .and. 
c     *                islhgt.gt.0 .and. iand(iornt,30737).eq.0) 
c      if (.not.btest(iornq,24) .and. 
      if (.not.btest(iornq,25) .and. 
     *                islhgt.gt.0 .and. iand(iornt,30737).eq.0) 
c     *  ioff = ioff+dim(islhgt+3,ihorn+ioff)
     *  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
c
c  Zero out the bit for ornament just dealt with.
c
c     if (notcrd) then
        iornq = ibclr(iornq,ibit)
c     else
c
c  Deal with this later
c
c       continue
c     end if
      if (lout .eq. 0) then
        outq = notexq(1:lnote)
      else
        outq = outq(1:lout)//notexq(1:lnote)
      end if
      lout = lout+lnote
c
c  Check bits 0-21, go back if any are still set
c
      if (iand(iornq,4194303) .gt. 0) go to 2
      return
      end
      subroutine putxtn(ntupv,iflop,multb,iud,wheadpt,poenom,
     *  nolev1,islope,slfac,xnlmid,islur,lnote,notexq,ncmid,nlnum,
     *  eloff,iup,irest)
c
c  Places digit for xtuplet.  
c
      character*8 noteq
      character*79 notexq
      logical btest
      ioff = (ntupv+1)/2
      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 = ni(xnlmid-1+3*iud+iflop*11+.1)
      end if
      if (.not.btest(islur,31)) then
c
c  Only print number when wanted.  First check vert, horiz offset
c
        if (btest(irest,1)) nlnum = nlnum+iand(31,ishft(irest,-2))-16 
        if (btest(irest,7)) eloff = eloff+
     *          (.1*iand(31,ishft(irest,-9))-1.6)*wheadpt/poenom
        notexq = char(92)//'xnum{'
        lnote = 10
        if (eloff .lt. 0.995) then
          write(notexq(7:10),'(i1,f3.2)')0,eloff
        else if (eloff .lt. 9.995) then
          write(notexq(7:10),'(f4.2)')eloff
        else
          write(notexq(7:11),'(f5.2)')eloff
          lnote = 11
        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 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
      character*128 lineq,lnholdq
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      logical mrecord,mplay,endmac
      if (.not.mrecord) then
c
c  Starting the macro
c
        open(20+macnum,status='SCRATCH')
        mrecord = .true.
      end if
      if (iccount .lt. 128) then
        ndxm = index(lineq(iccount+1:128),'M')
        if (ndxm .gt. 0) then
c
c  This line ends the macro.
c
          if (ndxm .gt. 1) write(20+macnum,'(a)')
     *                lineq(iccount+1:iccount+ndxm-1)
          mrecord = .false.
        else
c
c  This line just continues the macro
c
          write(20+macnum,'(a)')lineq(iccount+1:128)
        end if
      end if
      return
      end
      subroutine read10(string,lenstr,lastchar)
      character*(*) string
      character*128 lnholdq
      logical lastchar
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      logical mrecord,mplay,endmac
      if (.not.mplay) then
        read(10,'(a)',end=999)string(1:lenstr)
        return
999     lastchar = .true.
        return
      else
        read(20+macnum,'(a)',end=998)string
        return
998     mplay = .false.
        endmac = .true.
        return
      end if
      end
      subroutine getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
     *    xmtrnum0,npages,nsyst,musicsize,fracindent,istype0,
     *    inameq,clefq,sepsymq,pathnameq,lpath,isig0)
      parameter (nm=7)
      common /comnvi/ nvi(nm)
      character*1 clefq(nm),sepsymq(nm)
      character*40 pathnameq
      character*79 inameq(nm)
      character*128 lineq
      logical istype0
c
c  Get the first line
c
      iccount = 0
9     read(10,'(a)')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       read(10,'(a)')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 = readin(lineq,iccount,nline)+.1
      noinst = readin(lineq,iccount,nline)+.1
c
c  If noinst<0 , will have to read in nvi for each instrument
c
      if (noinst .le. 0) then
        noinst = noinst-1
        do 2 iin = 1 , -noinst
          nvi(iin) = readin(lineq,iccount,nline)+.1
2       continue
      end if
      mtrnuml = readin(lineq,iccount,nline)+.1
      mtrdenl = readin(lineq,iccount,nline)+.1
      mtrnmp = readin(lineq,iccount,nline)+.1
      mtrdnp = readin(lineq,iccount,nline)+.1
      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
      xdum = readin(lineq,iccount,nline)
      isig0 = xdum+.1
      if (xdum .lt. 0.) isig0 = xdum-.1
      npages = readin(lineq,iccount,nline)+.1
      nsyst = readin(lineq,iccount,nline)+.1
      musicsize = readin(lineq,iccount,nline)+.1
      fracindent = readin(lineq,iccount,nline)
c
c  Next noinst non-comment lines are names of instruments.  
c
      do 4 i = 1 , abs(noinst)
5       read(10,'(a79)')inameq(i)
        if (inameq(i)(1:1) .eq. '%') go to 5
4     continue
c
c  Mext non-comment line has nv clef names
c
6     read(10,'(a)')lineq
      if (lineq(1:1) .eq. '%') go to 6
      if (noinst .gt. 0) then
c
c  Old way
c
        nstaf1 = nv-noinst+1
        do 7 iv = 1 , nv
          clefq(iv) = lineq(iv:iv)
          if (iv .lt. nstaf1) then
            sepsymq(iv) = '|'
          else
            sepsymq(iv) = '&'
          end if
7       continue
      else
c
c  New way
c
        iv = 0
        nvtot = 0
        do 1 iinst = 1 , -noinst
          nvtot = nvtot+nvi(iinst)
          do 10 ivi = 1 , nvi(iinst)
            iv = iv+1
            clefq(iv) = lineq(iv:iv)
            if (iv .eq. nvtot) then
              sepsymq(iv) = '&'
            else
              sepsymq(iv) = '|'
            end if
10        continue
1       continue
      end if
c
c  Mext non-comment line has path name
c
8     read(10,'(a)')pathnameq
      if (pathnameq(1:1) .eq. '%') go to 8
      lpath = index(pathnameq,' ')-1
      return
      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
4     if (iccount .eq. 128) then
1       read(10,'(a)')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'
        stop 1
      end if
      icf = i2-i1+49
      read(lineq(i1:i2),'(f'//char(icf)//'.0)')readin
      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 putarp(itnow,iv,nolev,ncm,soutq,lsout)
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      logical lowdot
      character*80 soutq
      character*79 notexq  
      character*8 symq(2)
      data symq /'raisearp','arpeggio'/
      
c
c  Find which iarp, if any
c
      do 1 iarp = 1 , narp
        if (itnow .eq. itar(iarp)) go to 2
1     continue
c
c  If here, this is the *first* call for this arp.
c
      narp = narp+1
      itar(narp) = itnow
      ivar1(narp) = iv
      levar1(narp) = nolev
      ncmar1(narp) = ncm
      return
2     continue
c
c  If here, this is second call at this time, iarp points to values from 1st.
c
      if (iv .eq. ivar1(iarp)) then
c
c  Arp is in a single staff.
c
        levbot = min(levar1(iarp),nolev)-ncm+3
        invert = abs(levar1(iarp)-nolev)+1
      else
c
c  Arp covers >1 staff.  Lower staff has to be the first, upper is current and
c  is where the symbol will be written.
c
        levbot = -ni(2*xinsnow)+3+levar1(iarp)-ncmar1(iarp)
        invert = -levbot+4+nolev-ncm
      print*,'xinsnow,levar1,ncmar1,levbot,nolev,ncm:'
      write(*,'(f5.1,5i5)')xinsnow,levar1(iarp),ncmar1(iarp),
     *levbot,nolev,ncm
      end if
c
c  isym will be (1,2) if invert is (even,odd).  If even, raise .5\internote
c
      isym = mod(invert,2)+1
      ilvert = (invert+1)/2     
      if (levbot .ge. 0 .and. levbot .le. 9) then
c
c  Single digit
c
        notexq = char(92)//symq(isym)//char(48+levbot)
        lnote = 10
      else
        notexq = char(92)//symq(isym)//'{'
        if (levbot .ge. -9) then
c
c  Need two spaces for number
c
          write(notexq(11:13),'(i2,a1)')levbot,'}'
          lnote = 13
        else
          write(notexq(11:14),'(i3,a1)')levbot,'}'
          lnote = 14
        end if
      end if
      if (ilvert .le. 9) then
        call addstr(notexq(1:lnote)//char(48+ilvert),lnote+1,
     *              soutq,lsout)
      else
        write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}'
        call addstr(notexq(1:lnote+4),lnote+4,soutq,lsout)
      end if
c
c  cancel out the stored time, to permit two arps at same time!
c
      itar(iarp) = -1
      return
      end
      subroutine chkarp(found1,ncrd,icrdat,ivx,ip,isacc,isarp)
      logical found1,isacc,isarp,btest
      integer icrdat(93)
          found1 = .false.
          do 18 icrd = 1 , ncrd
            if (iand(255,icrdat(icrd)) .eq. ip  .and.
     *          iand(15,ishft(icrdat(icrd),-8)) .eq. ivx) then
              if (.not.found1) found1 = .true.
              isacc = isacc .or. btest(icrdat(icrd),19)
              isarp = isarp .or. btest(icrdat(icrd),25)
            else if (found1) then
c             go to 19
              return
            end if
18        continue
      return
      end
      subroutine putshft(ivx,onoff,soutq,lsout)
      parameter (nm=7)
      common /comudsp/udsp(25),itudsp(25),nudsp,udoff(nm,20),nudoff(nm),
     *                 uxsp(25),ivuxsp(25),ipuxsp(25),nuxsp
      character*80 soutq,notexq
      character*1 sq
      logical onoff 
      sq = char(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'//char(48+ifmt)//'.1)')xoff
         call addstr(sq//'off{'//notexq(1:ifmt)//'pt}',8+ifmt,
     *                   soutq,lsout)
      return
      end
      subroutine outbar(i,jlast)
      nfmt = log10(i+.5)+2
      if (jlast+5+nfmt .lt. 80) then
        write(*,'(a5,i'//char(48+nfmt)//',$)')'  Bar',i
        jlast = jlast+5+nfmt
      else
        write(*,'(/,a5,i'//char(48+nfmt)//',$)')'  Bar',i
        jlast = 5+nfmt
      end if
      return
      end
      subroutine dotmov(updot,rtdot,soutq,lsout)
      character*80 soutq,notexq
      character*1 sq
      sq = char(92)
      lfmtup = lfmt1(updot)
      lfmtrt = lfmt1(rtdot)
      write(notexq,'(a37,f'//char(48+lfmtup)//'.1,a2,f'//char(48+lfmtrt)
     *    //'.1,a14)')      
     * sq//'makeatletter'//sq//'def'//sq//'C@Point#1#2{'//sq//
     * 'PMXpt{',updot,'}{',rtdot,'}}'//sq//'makeatother'
c
c   Example of string just created:
c   \makeatletter\def\C@Point#1#2{\PMXpt{.5}{.5}}\makeatother\
c
      lnote = 53+lfmtup+lfmtrt
      call addstr(notexq(1:lnote),lnote,soutq,lsout)
      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  
        x = sign(.1*int(10*abs(x)+.5),x)
        lfmt1 = int(log10(1000*abs(x)+.001))
        if (x .lt. 0) lfmt1 = lfmt1+1
      end if
      return
      end
      subroutine getorn(lineq,iccount,iornq,iornq1,ornrpt,noffseg,
     *                  ip,ivx,noxtup,notcrd,nole)
c
c  iornq: Main note.  Do not alter if chord note, except turn on bit 23 
c  iornq1: Prior note, in case orn rpt toggle is on
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 /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      character*1 charq,durq
      character*128 lineq
      logical ornrpt,negseg,noxtup,notcrd
c
c  Bits 0-13: (stmgx+Tupf._), 14: Down fermata, was F, 15: Trill w/o "tr", was U
c  16-18 Editorial sharp, flat, natural "oes,f,n"; 19-20: >^, 21 TBD
c
c  Set signal on main note that some note at this time has ornament.  ONLY used
c  in beamstrt to activate further tests fo whether ihornb is needed.
c
      iornq = ibset(iornq,23)
c
c  Isolate 21 bits defining exisiting ornaments
c
      if (notcrd) then
        iorni = iand(4194303,iornq)
      else
        iorni = iand(4194303,icrdorn(ncrd))
      end if
      call getchar(lineq,iccount,charq) 
      korn = index('stmgx+Tupf._)e:XXX>^',charq)
      if (korn .ne. 15) iorni = ibset(iorni,korn)
c
c  Note that korn=0 => charq='(', and we set bit 0.  if "e" (14), alter later.
c  When this if-block is done, korn will = bit# of actual ornament.= 
c
      if (korn .eq. 15) then
c
c  Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-20 prev iornq
c
        iorni = ior(iorni,iand(iornq1,1638383))
        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) 
        korn = 15+index('sfn',durq)
        iorni = ibset(ibclr(iorni,14),korn)
        call getchar(lineq,iccount,durq) 
      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 = fnum+.1
          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
        stop 1
      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
c
        xofforn = 44-ichar(durq)
        iccount = iccount+1
        call readnum(lineq,iccount,durq,fnum)
        iofforn = ni(xofforn*fnum)
        kudorn(nudorn) = ip+ishft(ivx,8)+ishft(nole,12)+ishft(korn,19)
     *                   +ishft(iofforn+32,25)
      else if (durq .eq. ':') then
c
c  Turn on  repeated ornaments
c
        ornrpt = .true.
      end if   
      if (notcrd) then
        iornq = ior(iornq,iorni)
      else
        icrdorn(ncrd) = ior(icrdorn(ncrd),iorni)
      end if
      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)
c        iv = iand(7,isdata)             
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
      subroutine setbits(isdata,iwidbit,ishift,ivalue)
c
c  Sets iwidbits of isdata, shifted by ishift, to ivalue
c
      ibase = 2**iwidbit-1
      if (ivalue.gt.ibase) print*,'WARNING in setbits: ivalue > ibase'
      isdata = iand(not(ishft(ibase,ishift)),isdata)
      isdata = ior(isdata,ishft(ivalue,ishift))      
      return
      end
      subroutine precrd(ivx,ip,nolevm)
c
c  Analyzes chords, data to be used with slurs on chords and plain chords.
c 
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      do 1 icrd1 = 1 , ncrd
        if (iand(255,icrdat(icrd1)) .eq. ip  .and.
     *      iand(15,ishft(icrdat(icrd1),-8)) .eq. ivx) go to 2
1     continue
      print*
      print*,'Failed to find first chord note!'
      stop
2     continue
      maxlev = nolevm
      minlev = nolevm
      do 3 icrd2 = icrd1 , ncrd
c
c  Exit loop if last note in this chord
c
        nolev = igetbits(icrdat(icrd2),7,12)
        maxlev = max(maxlev,nolev)
        minlev = min(minlev,nolev)
        if (icrd2 .eq. ncrd) go to 4
        if (igetbits(icrdat(icrd2+1),8,0) .ne. ip  .or.
     *      igetbits(icrdat(icrd2+1),4,8) .ne. ivx) go to 4
3     continue
      print*
      print*,'Failed to find last chord note!'
      stop
4     continue      
c
c  Now icrd1, icrd2 define range of icrd for this chord.
c
      return
      end