ccccccccccccccccccccccccccccccccccccc
cc                                 cc
cc  pmxb.for  Version 1.1a 2/1/97  cc
cc                                 cc
ccccccccccccccccccccccccccccccccccccc
      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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
c
c  islur is used as a bank of switches
c  
c  bit     value meaning
c  0          1  start level 1 slur
c  1          2  stop level 1 slur
c  2          4  start level 2 slu
c  3          8  stop level 2 slur
c  4         16  grace
c  5         32  left repeat
c  6         64  right repeat
c  7        128  start Volta
c  8        256  doublebar
c  9        512  end Volta
c  10      1024  on=>endvoltabox
c  11      2048  on=>clefchange
c  12-14  -----  0=>treble, ... , 6=>bass 
c  15     32768  on=> start new block for clef change (maybe diff. voice)
c  16     65536  literal TeX string
c  17    131072  1=up, 0=down stem for single note (override)
c  18    262144  if on, prohibit beaming
c  19    524288  if on, full bar rest as pause
c  20            Beam multiplicity down-up
c  21            Override s-slur default direction
c  22            s-Slur dir'n: 1=up, 0=down
c  23            Override t-slur default direction
c  24            t-Slur dir'n: 1=up, 0=down
c  25            vert offset s-slur start/stop (value in ipl b21-b25)
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 (not done yet)
c  9        \roff 
c  10       chord present?
c  11-15    Forced beam height adjustment (-15 to +16)
c  16-20    Forced beam slope adjustment (-15 to +16)
c  21-25    s-slur height offset (-15 to +16)
c
cccccccccccccccccccccccccccccccc
      character*6 figq
      character*1 accq,ulq,ornq,sepsymq,sq
      logical beamon,rest,firstgulp,figbass,figcheck,
     *        isfig,rptprev,rptfin
      logical loop,lastchar,slint,svolta,evolta,onvolt,xtupb4
      integer nsystp(20)
      real*4 xnsttop(20),xintstaff(20),hesk(19),hpts(19)
      character*1  clefq(nm),ulfbq,accgq
      character*128 lineq
      character*79 notexq,inameq
      character*40 pathnameq
      character*24 basenameq,fmtq
      character*10 voltxtq
      character*6 nstartq(14)
      character*60 instrq,titleq,compoq
      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
      common /comstart/ nstartq,lstart(14),facmtr
      common /comfb/ nfb(nm),it1fb(nm,20),it2fb(nm,20),ulfbq(nm,20),ifb
      common /comget/ lastchar,rptprev,rptfin,sluron(nm,2)
      common /combeam/ ibmtyp
      common /comnotes/ nnodur,lastlev,ndlev(nm)
      common /comtop / itopfacteur,ibotfacteur,interfacteur,
     *   isig,fracindent,widthpt,height,inameq(nm)
      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 /combase/ lbase,basenameq
      common /comslur/ listslur,ndxslur(nm,2),upslur(nm,2)
      common /comsln/ is1n1,is2n1,irzbnd,isnx
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),
     *                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
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(43)
      character*80 litq
      logical upslur,bar1syst,vshrink,lrpt,rrpt,lrptpend,endon,
c    *   ispoi,bcspec,topmods,headlog,clchb,clchv(nm),flgndv,flgndb,
     *   ispoi,bcspec,topmods,headlog,clchb,clchv(nm),       flgndb,
     *   btest,sluron
      common /comcc/ ncc(nm),itcc(nm,10),ncmidcc(nm,10)
      common /compoi/ ispoi
      common /combc/ bcspec
      common /comeon/ eonk,ewmxk
      common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
     *                flagfac,dotfac,bacfac,agc1fac,gslfac,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac 
      common /comhsp/ hpttot(83)
      common /combmh/ bmhgt,clefend
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtrans/ ntrans
      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')
      read(10,*)nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0,idum,
     *          npages,nsyst,musicsize,fracindent
c
c See subroutine setmeter for mtrxxxl.  mtrxxxp are *printed* num and denom if
c mtrnmp>0.  If mtrnmp=0, mtrden has the following meaning:
c   0         Nothing printed
c   2, 3, 4   Just a single number
c   5         Allabreve
c   6         Common time
c   7         3 Slash
c If mtrnmp<0, put a full vertical slash through fractional time sig.
c
      read(12,*)npages,widthpt,height,nsyst,
     *   (nsystp(ipa),xnsttop(ipa),xintstaff(ipa),ipa=1,npages),iauto
      do 6 iinst = 1 , noinst
        read(10,'(a79)')inameq(iinst)
6     continue
      read(10,'(a128)')lineq
      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
      read(10,'(a)')pathnameq
      lpath = index(pathnameq,' ')-1
      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  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.
      nasksys = 0
      nasxsys = 0
      ibarcnt = 0
      iline = 0
      isystpg = 0
      ipage = 1
      iccount = 128
      iask = 0
      iasx = 0
      nhstot = 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
      is2n1 = 0
      isnx = 0
      ispoi = .false.
      slint = .false.
      lrptpend = .false.
      endon = .false.
      rptfin = .false.
      rptprev = .false.
      onvolt = .false.
      flgndb = .false.
      nhssys = 0
      listslur = 0
      do 1 ivx = 1 , nm
        ndxslur(ivx,1) = 0
        ndxslur(ivx,2) = 0
1     continue
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
      nlit = 0
      nvolt = 0
      ibarmbr = 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
        do 5 j = 1 , 200
          rest(iv,j) = .false.
          islur(iv,j) = 0
          ipl(iv,j) = 0
          accq(iv,j) = 'x'
          ornq(iv,j) = 'q'
          if (iv.eq.1) isfig(j) = .false.
5       continue
4     continue 
      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(..),rest(..).  
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
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
          print*,'Now processing bar #',ibarcnt+ibcoff
        else
          write(*,'(a19,i4,a1,i4)')' Multibar rest, bars',
     *       ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1
          ibcoff = ibcoff+mbrest-1
          if (ibar.eq.1 .and. firstgulp) xb4mbr = facmtr*musicsize 
        end if 
        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
        do 16 iv = 1 , nv
        do 16 kv = 1 , nvmx(iv)
          ivx = ivmx(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 are nb and iv set???  nb probably in left over from makeabar
c
        esk = feon(float(nspace(nb)))
c       if (xtupb4) esk = esk*xtfold(iv)
        ptsdflt = esk*poenom-wheadpt
        if (ptsndb .gt. ptsdflt) 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
          hesk(nhssys) = esk
          hpts(nhssys) = ptsndb+wheadpt
          fixednew = fixednew+hpts(nhssys)
          scaldold = scaldold+esk
        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
              call clefsym(islur(iv,ioff+1),fmtq,lclef,nclef)
              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
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
        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 (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. Get corrected poe = points/elemskip for *previous* system
c
            wdpt = widthpt
            if (iline .eq. 2) 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-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,iemin,iemax
c
c  Redefine notes as required. (mndef0,mx..)=range define notmally.
c
          if (iline.eq.1) then
c
c This may not work right if first line is tight and next is not.
c
            mndef0 = iemin
            mxdef0 = iemax
            mndef1 = 99
            mxdef1 = 0
            call defnotes(iemin,iemax)
          else if (eonk .gt. 0.001) then
            mndef1 = min(mndef1,iemin)
            mxdef1 = max(mxdef1,iemax)
            call defnotes(iemin,iemax)
          else
c
c  Basic spacing req'd.  Redefine everything betw mndef1 & mxdef1 , 
c  below mndef0 , and above mxdef0.
c
            call defnotes(mndef1,mxdef1)
            call defnotes(iemin,min(mndef0-1,mndef1-1))
            call defnotes(max(mxdef0+1,mxdef1+1),iemax)
            mndef0 = min(mndef0,iemin)
            mxdef0 = max(mxdef0,iemax)
            mndef1 = 99
            mxdef1 = 0
          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. max(is1n1,is2n1).gt.0) then
              isn1 = max(is1n1,is2n1)
              isn2 = 0
              ioff = 0
              if (ibar .gt. 1) ioff = nib(nv,ibar-1)
              if (is1n1 .gt. 0) then
c
c  Search forward for end of slur type 0 (s).  Remember, haven't slid down yet.
c  Note this will only work if critical slurs are in upper voice in staff #n
c
                do 50 ip = 1+ioff , nib(nv,ibar)
                  if (btest(islur(nv,ip),1)) then
                    isn2 = nolev(nv,ip)
                    go to 51
                  end if
50              continue
              end if
51            continue
              if (is2n1 .gt. 0) then
c
c  Search forward for end of slur type 1 (t).  
c
                do 52 ip = 1+ioff , nib(nv,ibar)
                  if (btest(islur(nv,ip),3)) then
                    isn2 = max(isn2,nolev(nv,ip))
                    go to 53
                  end if
52              continue
      print*,'Top line slur 1 started but did not stop?'
              end if
      if (isn2.eq.0) print*,'Trouble w/ ht. of end of over-line slurs'
53            continue
              isnx = idim(max(isn1,isn2),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 (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
              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//'stoppiece'//sq//'vskip',xnstbot,
     *              sq//'Interligne'//sq//'eject%'
              else
                write(11,'(a)')
     *                sq//'stoppiece'//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 (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)
                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
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 (mtrnuml .eq. 0) then
c
c  No meter change
c
                write(11,'(a)')sq//'alaligne'
              else
c
c  New meter
c
                call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
                call wgmeter(mtrnmp,mtrdnp)
                if (mtrdnp .gt. 0) then
                  write(11,'(a)')sq//'newtimes1%'
                  if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize 
                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
          end if
          read(12,*,end=14)iauto
14        continue
        else  
c
c  Not first bar of system
c
          if (mtrnuml .eq. 0) then
c
c  No meter change
c
            write(11,'(a)')sq//'xbar'
          else
c
c  Change meter
c
            call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
            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
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)
              rest(ivx,ip) = rest(ivx,ip+ioff)
              islur(ivx,ip) = islur(ivx,ip+ioff)
              ipl(ivx,ip) = ipl(ivx,ip+ioff)
              ornq(ivx,ip) = ornq(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
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 makeabar(ibmrep,noinst,clefq)
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
        ask(iask) = wasksys(ia)/poe-elasksys(ia)
19    continue
      do 18 ia = 1 , nasxsys
        iasx = iasx+1
        asx(iasx) = wasxsys(ia)/poe-elasxsys(ia)
c     print*,'iasx,asx,ia,wasxsys,poe,elasxsys:'
c     print*,iasx,asx(iasx),ia,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 (rptfin) then
        write(11,'(a)')sq//'setrightrepeat'//sq//'endpiece'
      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)
      print*,'Done with second pass.  Now run TeX'
      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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      character*6 figq
      character*1 accq,ulq,ornq,sepsymq,sq
      logical beamon,rest,firstgulp,figbass,figcheck,
     *        isfig
      character*60 instrq,titleq,compoq
      common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
     *    inhead,inbothd
      common /comfig/ itfig(74),figq(74),nfigs
      common /comnotes/ nnodur,lastlev,ndlev(nm)
      common /comget/ lastchar,rptprev,rptfin,sluron(nm,2)
      common /comhead/ ihdht,lower,headrq,lowerq
      common /comfb/ nfb(nm),it1fb(nm,20),it2fb(nm,20),ulfbq(nm,20),ifb
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),
     *                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
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(43)
      character*80 litq
      common /comcc/ ncc(nm),itcc(nm,10),ncmidcc(nm,10)
      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,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac 
      common /comtrans/ ntrans
      character*128 lineq
      character*80 headrq, lowerq
      character*59 hdlndq
      character*10 voltxtq
      character*1 charq,dotq,durq,ulfbq,accgq
      logical loop,lastchar,lower,rptprev,rptfin,negseg,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 'l' or 'r'
c
      if (rptprev) then
        if (charq.ne.'/') then
          rptprev = .false.
        else
          rptfin = .true.
        end if
      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
        if (nnl(ivx).eq.0 .and. ndlev(ivx).gt.0) lastlev = ndlev(ivx)
        nnl(ivx) = nnl(ivx)+1
        dotq = 'x'
        rest(ivx,nnl(ivx)) = charq .eq. 'r'
        numnum = 0
        if (rest(ivx,nnl(ivx))) 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 .and. rest(ivx,nnl(ivx)-1) .and.
     *      nodur(ivx,nnl(ivx)-1) .eq. lenbar) 
     *      islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19)
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
          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 (durq .eq. '+') then
          if (.not.rest(ivx,nnl(ivx))) then
            lastlev = lastlev+7
            go to 2
          else
c
c  Override default height; raise a rest
c
            call getchar(lineq,iccount,durq)
            call readnum(lineq,iccount,durq,fnum)
            nolev(ivx,nnl(ivx)) = 100+fnum+.1
c
c  Note: assuming there are no more symbols for this rest!  Check in pmxa.
c
          end if
        else if (durq .eq. '-') then
          if (.not.rest(ivx,nnl(ivx))) then
            lastlev = lastlev-7
            go to 2
          else
            call getchar(lineq,iccount,durq)
            call readnum(lineq,iccount,durq,fnum)
            nolev(ivx,nnl(ivx)) = 100-int(fnum+.1)
          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') islur(ivx,nnl(ivx)) = 
     *        ibset(islur(ivx,nnl(ivx)),31)
          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
          numnum = 0
          nodur(ivx,nnl(ivx)) = 0
          do 6 itup = 2 , ntup
            nnl(ivx) = nnl(ivx)+1
7           call getchar(lineq,iccount,charq)
            if (charq .eq. ' ') then
              go to 7
            else if (charq .eq. 's') then
              call sslur(1,islur(ivx,nnl(ivx)-1),sluron(ivx,1),
     *                   lineq,iccount,ipl(ivx,nnl(ivx)-1))
              go to 7
            else if (charq .eq. sq) then
              call littex(islur,nnl(ivx),ivx,topmods,lineq,iccount)
              go to 7
            else if (index('0123456789#-nx',charq) .gt. 0) then
c
c  Figure.  Must come AFTER the first note of xtup
c
              nfigs = nfigs+1
              call getfig(itoff(nfigs),charq,lineq,iccount,
     *                    isfig(nnl(ivx)),itfig(nfigs),itsofar,
     *                    nodur(ivx,nnl(ivx)),figq(nfigs))
              go to 7
            end if
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 this if block
c
              lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7)
              nolev(ivx,nnl(ivx)) = lastlev
              nodur(ivx,nnl(ivx)) = 0
            end if
6         continue
        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 .ne. ' ') then
          print*,'Illegal character in note: ',durq,', ivx,nn:',
     *        ivx,nnl(ivx)
          stop
        end if
        if (.not.rest(ivx,nnl(ivx))) 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
        end if
        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
        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 
      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.
c  Doesn't increase # of notes, so must handle separately
c  ncrd: index of crd
c  Bits is 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
        ncrd = ncrd+1
        ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),10)
c 11-14-96 ???       icrdat(ncrd) = 0
        numnum = 0
        icrdat(ncrd) = ior(nnl(ivx),ishft(ivx,8)) 
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+-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) 
          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))
      else if (charq .eq. 'G') then
c
c Grace, comes *before* main note:  
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 (charq .eq. 'm') then
          call getchar(lineq,iccount,charq)
          multg(ngrace) = ichar(charq)-48
          go to 18
        else if (index('123456789',charq) .gt. 0) then
          call readnum(lineq,iccount,durq,fnum)
          iccount = iccount-1
          nng(ngrace) = int(fnum+.1)
          go to 18
        else if (charq .eq. 'l') then
          upg(ngrace) = .false.
          go to 18
        else if (charq .eq. 's') then
          slurg(ngrace) = .true.
          go to 18
        else if (charq .eq. 'x') then
          slashg(ngrace) = .true.
          go to 18
        else if (charq .eq. 'u') then
          go to 18
        end if
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)) call getchar(lineq,iccount,charq)
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
      loldlast = lastlev
            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) ndlev(ivx)=lastlev
      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  "o" symbol must come AFTER the affected note
c
        call getchar(lineq,iccount,ornq(ivx,nnl(ivx))) 
        if (ornq(ivx,nnl(ivx)) .eq. 'g') then
c
c  segno. Check in mx..a for just 1/block.  Get horizontal offset in points
c
          noffseg = 0
          negseg = .false.
12        call getchar(lineq,iccount,durq) 
          if (durq .eq. '-') then
            negseg = .true.
            go to 12
          else if (durq .ne. ' ') then
            noffseg = noffseg*10+ichar(durq)-48
            go to 12
          end if
          if (negseg) noffseg = -noffseg          
        else if (ornq(ivx,nnl(ivx)) .eq. 'T') then
c
c  Trill.  Default is 1 noteskip long, with "tr"
c
          ntrill = ntrill + 1
          ivtrill(ntrill) = ivx
          iptrill(ntrill) = nnl(ivx)
          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
            ornq(ivx,nnl(ivx)) = 'U'
            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
        end if
      else if (charq .eq. 's') then
        call sslur(1,islur(ivx,nnl(ivx)),sluron(ivx,1),
     *              lineq,iccount,ipl(ivx,nnl(ivx)))
c
c  's' is toggle for level 0 slurs, 't' for level 1.
c  For level 0 slurs, islur=1=>start, 2=>stop, 3=>stop-start
c  For level 1 slurs, 4=>start, 8=>stop, 12=>stop-start
c
      else if (charq .eq. 't') then
        call sslur(2,islur(ivx,nnl(ivx)),sluron(ivx,2),
     *                   lineq,iccount,ipl(ivx,nnl(ivx)))
      else if (index('0123456789#-nx',charq) .gt. 0) then
c
c  We have a figure.  Must come AFTER the note it goes under
c
        nfigs = nfigs+1
        call getfig(itoff(nfigs),charq,lineq,iccount,isfig(nnl(ivx)),
     *            itfig(nfigs),itsofar,nodur(ivx,nnl(ivx)),figq(nfigs))
      else if (charq .eq. '[') then
c
c  Start forced beam.  Record barno & time since start of input block.
c
        nfb(ivx) = nfb(ivx)+1
        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 .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
c
            ipl(ivx,nnl(ivx)+1) = 
     *           ior(ipl(ivx,nnl(ivx)+1),ishft(iadj+15,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+15,16))
          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)  
        if (charq .eq. ' ') then
c
c  Since ']' comes AFTER note, itsofar has been updated
c
          it2fb(ivx,nfb(ivx)) = itsofar(ivx)
        else 
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)
        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 (index('wSL|',charq) .gt. 0) then
c 
c  Width symbol, new nsyst, Line break, Bar symbol.  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)
        if (durq .eq. 'l') then
          islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),5)
          rptprev = .true.
          go to 10
        else if (durq .eq. 'r') then
          islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),6)
          rptprev = .true.
          go to 10
        else if (durq .eq. 'd') then
          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)
          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. '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
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
        end if
      else if (charq .eq. 'K') then
        isign = +1
        call getchar(lineq,iccount,durq)
        if (durq .eq. '-') isign = -1
        iccount = iccount+1
        call readnum(lineq,iccount,durq,fnum)
        ntrans = int(fnum+.1)*isign
c
c  On exit, durq must be '+','-'.  But don't need to get isig, done in pmxa
c
        iccount = iccount+1
        call readnum(lineq,iccount,durq,fnum)
      else if (charq .eq. '/') then
        ndlev(ivx) = lastlev
        call getchar(lineq,iccount,durq)
        if (durq .eq. ' ' .and. iv.eq.nv) then
c
c  End of input block
c
          loop = .false.
        else 
c
c  Start a new voice
c
          if (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  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
            do 24 j = 1 , 200
              rest(ivx,j) = .false.
              islur(ivx,j) = 0
              accq(ivx,j) = 'x'
              ornq(ivx,j) = 'q'
              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 (rest(iv,j) .and. nolev(iv,j).eq.0) nolev(iv,j) = -4
26          continue
          end if
        end if
        iccount = 128
      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,rptprev,rptfin,sluron(nm,2)
      logical lastchar,rptprev,rptfin,sluron
      character*1 charq
      character*128 lineq
      if (iccount .eq. 128) then
        read(10,'(a128)',end=999)lineq
        iccount = 0
      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+.0001
      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. 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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      character*1 accq,ulq,ornq,sepsymq,sq
      character*79 inameq
      logical beamon,rest,firstgulp,figbass,figcheck,
     *        isfig,vxtup,bar1syst,inxtup
      common /comoct/ noctup
      common /strtmid/ ihnum3
      common /comxtup/ xtupfac(nm),n2xtup(20),ixtup,vxtup(nm),inxtup,
     *                 ntupv(nm)
      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,
     *   isig,fracindent,widthpt,height,inameq(nm)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*8 noteq
      character*79 notexq
      real*4 xelsk(24)
      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,nornb,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 (.not.btest(islur(ivx,ipb1),31)) then
c
c  Need a number.  Get eloff = elskips from start to middle note of stup
c
            ioff = (ntupv(ivx)+1)/2
            if (mod(ntupv(ivx),2) .eq. 0) then
              eloff = (xelsk(ioff)+xelsk(ioff+1))/2
            else
              eloff = xelsk(ioff)
            end if
            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
            notexq = sq//'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(iv,ipb1))
            notexq = notexq(1:lnote)//'}'//noteq(1:lnoten)
            lnote = lnote+1+lnoten
            if (ntupv(ivx) .lt. 10) then
              write(notexq(lnote+1:lnote+1),'(i1)')ntupv(ivx)
              lnote = lnote+1
            else
              notexq = notexq(1:lnote)//'{'
              write(notexq(lnote+2:lnote+3),'(i2)')ntupv(ivx)
              notexq = notexq(1:lnote+3)//'}'
              lnote = lnote+4
            end if
          end if
          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(31,ishft(ipl(ivx,ipb1),-11))-15
        if (iadj .ne. -15) nolev1 = nolev1+iadj
        iadj = iand(31,ishft(ipl(ivx,ipb1),-16))-15
        if (iadj .ne. -15) islope = islope+iadj
        iadj = iand(3,ishft(islur(ivx,ipb1),-27))
        call ntrbbb(multb+iadj,'i',ulq(ivx,ibc),ivx,notexq,lnote)
c
c   Put in name start level and slope
c
        call notefq(noteq,lnoten,nolev1,ncmid(iv,ipb1))
        if (islope .lt. 0) then
          notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
          lnote = lnote+4+lnoten
          write(notexq(lnote-2:lnote),'(i2,a1)')islope,'}'
        else
          notexq = notexq(1:lnote)//noteq(1:lnoten)
          lnote = lnote+1+lnoten
          write(notexq(lnote:lnote),'(i1)')islope
        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  Following group moved from above 10/13/96
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
        if (nornb(ivx) .gt. 0) then
          NomOrnLev = ncmid(iv,ipb1)+5
          iorn = 0
          do 8 inb = 1 , nnb
            if (index('qg',ornq(ivx,ipb(inb))) .eq. 0) then
              iorn = iorn+1
              if (ulq(ivx,ibc) .eq. 'l') then
                ihornb(ivx,iorn) = max(nolev(ivx,ipb(inb))+2,NomOrnLev)
              else
                ybeam = nolev1+stemlen+islope*xelsk(inb)/slfac-1
     *                  +1.2*(multb-1)
                ihornb(ivx,iorn) = max(ni(ybeam+3.5),NomOrnLev)
              end if
            end if
8         continue
c
c   Henceforth norn(ivx) will be a counter.  Zero it out when beam is finished
c
          nornb(ivx) = 1
        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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      character*1 accq,ulq,ornq,sepsymq,sq
      logical beamon,rest,firstgulp,figbass,figcheck,
     *        isfig,vxtup,inxtup
      common /comoct/ noctup
      common /comxtup/ xtupfac(nm),n2xtup(20),ixtup,vxtup(nm),inxtup,
     *                 ntupv(nm)
      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
        multr = mult(ivx,ip1+1)
        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  
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
        if (.not.vxtup(ivx)) then
          nd = nodur(ivx,list(2,jn))
          if (nd.ne.0 .and. 2**log2(nd).ne.nd) then
            if (ornq(ivx,ip1) .ne. ')') then
              notexq = notexq(1:lnote)//'p'
            else
              notexq = notexq(1:lnote)//'m'
            end if
            lnote = lnote+1
          end if
        end if
        lnote = lnote+1
        write(notexq(lnote:lnote),'(i1)')ivx
        notexq = notexq(1:lnote)//noteq(1:lnoten)
        lnote = lnote+lnoten
      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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      character*1 accq,ulq,ornq,sepsymq,sq
      logical beamon,rest,firstgulp,figbass,figcheck,
     *        isfig,vxtup,inxtup
      common /comoct/ noctup
      common /comxtup/ xtupfac(nm),n2xtup(20),ixtup,vxtup(nm),inxtup,
     *                 ntupv(nm)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      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 First check if multiplicity has increased
c
        mp = mult(ivx,ip-1)
        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
c
c Now the normal beam termination
c
        call ntrbbb(1,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
c
c  And now the note
c
        notexq = notexq(1:lnote)//sq//'qb'
        lnote = lnote+3
        if (.not.vxtup(ivx) .and. 
     *       2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then      
          if (ornq(ivx,ip) .ne. ')') then
            notexq = notexq(1:lnote)//'p'
          else
            notexq = notexq(1:lnote)//'m'
          end if
          lnote = lnote+1
        end if
        lnote = lnote+1
        write(notexq(lnote:lnote),'(i1)')ivx
        notexq = notexq(1:lnote)//noteq(1:lnoten)
        lnote = lnote+lnoten
      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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      character*1 accq,ulq,ornq,sepsymq,sq
      logical beamon,rest,firstgulp,figbass,figcheck,
     *        isfig,vxtup,inxtup,btest
      character*79 notexq
      common /comoct/ noctup
      common /strtmid/ ihnum3
      common /comxtup/ xtupfac(nm),n2xtup(20),ixtup,vxtup(nm),inxtup,
     *                 ntupv(nm)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*8 noteq
        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 Check if multiplicity changes in a way requiring action
c
        ipleft = ip-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 (.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
        if (.not.vxtup(ivx) .and. 2**log2(nodur(ivx,ip)).ne.
     *          nodur(ivx,ip)) then      
          if (ornq(ivx,ip) .ne. ')') then
            notexq = notexq(1:lnote)//'p'
          else
            notexq = notexq(1:lnote)//'m'
          end if
          lnote = lnote+1
        end if
        lnote = lnote+1
        write(notexq(lnote:lnote),'(i1)')ivx
        notexq = notexq(1:lnote)//noteq(1:lnoten)
        lnote = lnote+lnoten
      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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*1 accq,ulq,ornq,sepsymq,sq
      logical beamon,rest,firstgulp,figbass,figcheck,
     *        isfig,ispoi,btest
      character*1 udq,udqq,dotq
      character*79 notexq
c      character*(*) notexq
      character*8 noteq,restq
      common /compoi/ ispoi
        ip = list(2,jn)
        nole = nolev(ivx,ip)
        nodu = nodur(ivx,ip) 
        if (.not.rest(ivx,ip)) 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.rest(ivx,ip)) 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.rest(ivx,ip)) 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
            dotq = 'p'
            if (ornq(ivx,ip) .eq. ')') 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
          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
                notexq = sq//'liftpause'
                lnote = 10
              end if
c
c  (May want to define lift...p later) Set up height spec
c
              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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      common /combeam/ ibmtyp
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*1 accq,ulq,ornq,sepsymq,sq
      logical beamon,rest,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.rest(ivx,ip)
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
          if (short(ir).and.((ir.gt.1.and.short(ir-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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      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,ornq,sepsymq,sq,ulfq,ulfbq
      logical beamon,rest,firstgulp,figbass,figcheck,isfig
      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.
      if (nodur(ivx,nip1) .eq. 0) then
c
c  Xtuplet.  Set universal multiplicity
c
        multx = int(10.5+2.929+(0.952*alog(1.+nip2-nip1)- 
     *                   alog(nodur(ivx,nip2)/2.))/0.69315)-10
        do 8 iip = nip1 , nip2
          mult(ivx,iip) = multx
          sum = sum+nolev(ivx,iip)
8       continue
      else
        do 9 iip = nip1 , nip2
          mult(ivx,iip) = 4-log2(nodur(ivx,iip))
          sum = sum+nolev(ivx,iip)
9       continue
      end if
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) = 
     *      ulfq(sum/(nip2-nip1+1),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,
     *   isig,fracindent,widthpt,height,inameq(nm)
      character*79 inameq
      character*24 basenameq,fmtq
      character*5 fbarq
      character*1 clefq(nm),sq
      character*6 nstartq(14)
      common /comstart/ nstartq,lstart(14),facmtr
      logical vshrink
      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{',noinst,'}'
      iv = 0
      do 1 iinst = 1 , noinst
        if (noinst.eq.nv .or. iinst.gt.1) then
          nstaves = 1
        else
          nstaves = nv-noinst+1
        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'
      else
        write(11,'(a)')sq//'stafftopmarg0pt'//
     *         sq//'staffbotmarg5'//sq//'Interligne'//sq//
     *         'interstaff{10}'//sq//'relax'
      end if
      if (nv.eq.1) write(11,'(a)')sq//'nostartrule'
      write(11,'(a)')sq//'readmod{'//basenameq(1:lbase)//'}'
      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(mtrnl,mtrdl,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 (mtrdl .eq. 4) then
        if (mod(mtrnl,3).eq.0) then
          ibmtyp = 2
          ibmrep = mtrnl/3
        else
          ibmtyp = 1
          ibmrep = mtrnl/2
        end if
      else if (mtrdl .eq. 2) then
        ibmtyp = 1
        if (mtrnl .eq. 3) then
          ibmrep = 3
        else
          ibmrep = 2*mtrnl/mtrdl
        end if
      else 
c
c  Assumes mtrdl=8 and 3/8, 6/8, 9/8, or 12/8
c
        ibmtyp = 3
        ibmrep = mtrnl/3
      end if
c
c  Reset so we don't keep writing new meters
c
      mtrnl = 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(islur,nolev,ncm,beamon,iv,nv,j,ulq,
     *                  soutq,lsout,ipl)
      parameter (nm=7)
      common /comslur/ listslur,ndxslur(nm,2),upslur(nm,2)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*1 ulq,slurudq,udfq,udqq
      character*79 notexq
      character*8 noteq
      character*80 soutq
      logical upslur,beamon,btest,stemup,shift
c
c  Set  start, stop, or startstop if islur = 1,2,3.
c  In here, upslur is true if up slur, false if down. Must set this in case
c    slur ending needs to be offset.  nolev<0 => offset is needed.
c  In listslur bit ib is on if slur index ib is in use, ib=0-8.
c  ndxslur(ivx,j) = slur index 
c  
      nole = abs(nolev)
      ivoff = 0
      if (j .eq. 1 .and. btest(islur,25)) then
        ivoff = iand(31,ishft(ipl,-21))-15
      end if
      iupdn = 0
      shift = .false.
      if (nvmx(iv) .eq. 2) then
c
c  Two voices
c
        stemup = ivx .gt. nv
      else
c
c  One voice
c
        if (beamon) then
          stemup = ulq .eq. 'u'
        else
          stemup = udqq(nole,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u'
        end if
      end if
      if (btest(islur,0)) then
c
c  Slur is starting. Define slurudq.
c
        if (btest(islur,19+2*j)) then
c
c  Force slur direction
c
          if (btest(islur,20+2*j)) then
            slurudq = 'u'
          else
            slurudq = 'd'
          end if
        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(nole,ncm)
              else
c
c  In a beam
c
            if (ulq .eq. 'u') then
              slurudq = 'd'
            else
              slurudq = 'u'
            end if
          end if
        else
c
c  Two voices per line.  Get default
c
          if (ivx .le. nv) then
c
c  Lower voice of the two, so down slur
c
            slurudq = 'd'
          else
            slurudq = 'u'
          end if
        end if
c
c  Save up/down-ness for use at termination
c
        upslur(ivx,j) = slurudq.eq.'u'
        if (j .eq. 2) then
c
c  This is a 't' type slur, so record up-down-ness in case termination must
c    be raised or lowered
c
          if (nolev .lt. 0) then
            iupdn = -1
            if (upslur(ivx,2)) iupdn = 1
          end if
        end if
        if (iand(3,islur) .eq. 1) then
          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(ivx,j) = log2(511-listslur)
c
c  Turn on slur level j
c
          listslur = ibset(listslur,ndxslur(ivx,j))
          lnote2 = 0
          if (.not.(stemup.and.slurudq.eq.'u')) then
c
c  Write stuff for non-shifted pure start
c
            notexq = char(92)//'islur'//slurudq
            lnote = 7
          else
            notexq = char(92)//'is'//slurudq
            shift = .true.
            lnote = 4
          end if
        else
c
c  Stop and start a slur.  
c
          notexq = char(92)//'cslur'//slurudq
          lnote = 7
        end if
        notexq = notexq(1:lnote)//char(48+ndxslur(ivx,j))
        lnote = lnote+1
        call notefq(noteq,lnoten,nole+iupdn+ivoff,ncm)
        notexq = notexq(1:lnote)//noteq(1:lnoten)
        lnote = lnote+lnoten
        if (iand(3,islur) .eq. 3) then
c
c  Need to write note twice due to octaviation.
c
          call notefq(noteq,lnote2,nole+iupdn+ivoff,ncm)
          notexq = notexq(1:lnote)//noteq(1:lnote2)
          lnote = lnote+lnote2
        end if
        if (shift) then
          notexq = notexq(1:lnote)//'{.8}'
          lnote = lnote+4
        end if
        call addstr(notexq,lnote,soutq,lsout)
      else 
c
c  Slur is ending
c
        if (nolev .lt. 0) then
          iupdn = -1
          if (upslur(ivx,2)) iupdn = 1
        end if
        if (stemup .or. upslur(ivx,j)) 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
          shift = .true.
        end if
        notexq = notexq(1:lnote)//char(48+ndxslur(ivx,j))
        lnote = lnote+1
        call notefq(noteq,lnoten,nole+iupdn+ivoff,ncm)
        notexq = notexq(1:lnote)//noteq(1:lnoten)
        lnote = lnote+lnoten
        if (shift) then
          notexq = notexq(1:lnote)//'{-.8}'
          lnote = lnote+5
        end if
        call addstr(notexq,lnote,soutq,lsout)
        listslur = ibclr(listslur,ndxslur(ivx,j))
      end if
      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)
      common /comas1/ naskb,itask(20),wask(20),elask(20),iasxb,
     *                nasxb,ipasx(20),ivasx(20),wasx(20),elasx(20)
        nasxb = nasxb+1
        ipasx(nasxb) = ip
        ivasx(nasxb) = iv
        wasx(nasxb) = wasxn
        elasx(nasxb) = elasxn
        fixednew = fixednew+wasxn
        scaldold = scaldold+elasxn
      return
      end
      subroutine addask(itaskn,waskn,elaskn,fixednew,scaldold)
      common /comas1/ naskb,itask(20),wask(20),elask(20),iasxb,
     *                nasxb,ipasx(20),ivasx(20),wasx(20),elasx(20)
        if (naskb.gt.0 .and. itaskn.eq.itask(naskb)) then
c
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
      return
      end
      subroutine askfig(pathnameq,lpath,basenameq,lbase,figbass)
      logical figbass,ispoi,topmods
      common /comhsp/ hpttot(83)
      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  Copy first 7 lines from internal .tex (scratch unit 11)
c
      do 3 il = 1 , 7
        read(11,'(a129)')outq
        lenout = llen(outq,129)
        write(12,'(a)')outq(1:lenout)
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
        do 4 il = 1 , 1000
          read(14,'(a129)',end=5)outq
          lenout = llen(outq,129)
          write(12,'(a)')outq(1:lenout)
4       continue
5       continue
        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)
          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.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)'
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
        tag = outq(indxask+9:)
        write(outq(indxask+3:),fmtq)'t{',dim(elask,0.)
        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(j,islur,sluron,lineq,iccount,ipl)
c
c  Read in information for a slur
c
      logical btest,sluron
      character*128 lineq
      character*1 durq,dumq
c
c  's' is toggle for level j=1 slurs, 't' for level j=2.
c  in islur(ivx,ip), bit 0 means start type 1 slur
c                        1       stop       1
c                        2       start      2
c                        3       stop       3 
cc  ndxslur(ivx,j) = slur index + 1 (i.e., 0 if slur is off) ??
c  ndxslur(ivx,j) = slur index 
c  In listslur bit ib is on if slur index ib is in use, ib=0-8.
      if (sluron) then
c
c  Slur is already on.  Did we just start a slur on *this* note nnl
c
        if (btest(islur,2*j-2)) then
          print*,'Started and stopped a slur on same note'
          stop
        end if
c
c  Turn off slur level j
c
        islur = ibset(islur,2*j-1)
      else
        islur = ibset(islur,2*j-2)
      end if
      sluron = .not.sluron
1     call getchar(lineq,iccount,durq)
      if (index('uld',durq) .gt. 0) then
c
c  Force direction
c
        islur = ibset(islur,21)
        if (durq .eq. 'u') islur = ibset(islur,22)
        go to 1
      else if (index('+-',durq) .gt. 0) then
c
c  Vertical offset 
c
        islur = ibset(islur,25)
        iccount = iccount+1
        call readnum(lineq,iccount,dumq,fnum)
        iccount = iccount-1
        ioff = int(fnum+.5)
        if (durq .eq. '-') ioff = -ioff
        ipl = ior(ipl,ishft(ioff+15,21))
        go to 1
      end if
      return
      end
      subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,
     *                  islope,smed,nolev1,nornb,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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      character*1 accq,ulq,ornq,sepsymq,sq
      logical beamon,rest,firstgulp,figbass,figcheck,
     *        isfig,vxtup,inxtup,l1ng,l2ng,bar1syst
      real*4 xelsk(24),slope(800)
      integer ipb(24),nornb(nm)
      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)
      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)))
        nornb(ivx) = 0
c
c Need to figure how many elemskips to each note. Use the list,
c counting only those members that have a non-zero interval to next note
c
        elsksum = 0.
        iiasxb = iasxb
        nnb = 0
        sumx = 0.
        sumy = 0.
        if (vxtup(ivx)) then
c
c  Elsk/notesk is constant.  Need to find nspace for the block.  It is the
c  next nonzero list(4,in) on or after n2
c
          iin = n2-1
1         iin = iin+1
          if (list(4,iin) .eq. 0) go to 1
          elsperns =xtupfac(ivx)*feon(float(list(4,iin)))
c     print*,'itime,xtf,eon,poenom:',list(4,iin),xtupfac(ivx),elsperns,
c    *       poenom
          epns = elsperns
        end if
        do 2 in = n1, n2
          if (list(1,in).eq.ivx) then
            nnb = nnb+1
            ipb(nnb) = list(2,in)
            xelsk(nnb) = elsksum
            sumx = sumx+xelsk(nnb)
            sumy = sumy+nolev(ivx,ipb(nnb))
            if (index('qg',ornq(ivx,ipb(nnb))) .eq. 0) 
     *              nornb(ivx) = nornb(ivx)+1
          end if
          if (in. lt. n2) then
            if (list(4,in).ne.0 .and. .not.vxtup(ivx)) then
              elsperns = feon(float(list(4,in)))*xtupfac(ivx)
              elsksum = elsksum+elsperns
            else if (vxtup(ivx) .and. list(1,in).eq.ivx) then
              elsksum = elsksum+elsperns
            end if
            if (vxtup(ivx) .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+(apt+wheadpt)/poenom-elsperns
              iiasxb = iiasxb+1
            end if
          end if
2       continue
        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)
        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)) then
c
c  This first check is to save trouble of putting xtup's in setbm2.
c  The final check is that first and last stems aren't both excessive.
c
          call setbm2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1)
        end if
c 
c  Check if beam starts of 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
          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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*1 accq,ulq,ornq,sepsymq,sq
      logical beamon,rest,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(14)
      common /comstart/ nstartq,lstart(14),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,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac 
      common /combmh/ bmhgt,clefend
      data gslfac /9./
      data nstartq /'notss ','dummy ','notes ','notesp','Notes ',
     *              'Notesp','NOtes ','NOtesp','NOTes ','NOTesp',
     *              'NOTEs ','NOTEsp','NOTES ','NOTESp'/
      data lstart /5,5,5,6,5,6,5,6,5,6,5,6,5,6/
      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
     *  /   1.32 ,  2.25   ,  0.47 , 0.83  ,   0.17 , 0.5 / 
      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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      character*1 accq,ulq,ornq,sepsymq,sq
      logical beamon,rest,firstgulp,figbass,figcheck,isfig
      common /comcc/ ncc(nm),itcc(nm,10),ncmidcc(nm,10)
      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
      subroutine makeabar(ibmrep,noinst,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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      character*6 figq
      character*1 accq,ulq,ornq,sepsymq,sq
      logical beamon,rest,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
      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),
     *                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*80 litq
      common /comcc/ ncc(nm),itcc(nm,10),ncmidcc(nm,10)
      integer it(nm),cnn(nm),istart(20),istop(20),itstart(20),iaskb(nm),
     *   nindex(20),numbms(nm),nornb(nm),ihornb(nm,24),
     *   mapfb(4),it1xtup(20),n1xtup(20),lbxtup(20)
      character*1 upcaseq,ulfbq,accgq,udqq,clefq(nm)
      character*8 noteq
      character*79 cwrq
      character*10 voltxtq
      common /comoct/ noctup
      character*80 soutq,headrq,lowerq
      character*79 notexq
      common /comnsp/ nspace(20),nb,xtfold(nm),xtupb4,lastnodur(nm),
     *    flgndv(nm),flgndb
      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
      real*4 ptgr(37),ptclef(5)
      common /comxtup/ xtupfac(nm),n2xtup(20),ixtup,vxtup(nm),inxtup,
     *                 ntupv(nm)
      character*3 acsymq
      character*6 nstartq(14)
      common /comstart/ nstartq,lstart(14),facmtr
      common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
     *                flagfac,dotfac,bacfac,agc1fac,gslfac,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac 
c
c  Factors for grace note, clef spacing. (fraction of wheadpt or apt)
c  In 1.04, moved to block data subprogram
c
      common /comslur/ listslur,ndxslur(nm,2),upslur(nm,2)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
c
c  Time from start of gulp to end of bar, used with forced beams
c
      itgulp2 = lenb0+ibar*lenb1 
      if (lenb0 .gt. 0) itgulp2 = itgulp2-lenb1 
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
      inxtup = .false.
      nxtup = 0
      do 4 iv = 1 , nv
      do 4 kv = 1 , nvmx(iv)
        ivx = ivmx(iv,kv)
        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  Put xtuplet in a forced beam.  Must put in order with all fb's in gulp.
c
            call addfb(nfb,ivx,it1xtup(nxtup)+itgulp2-lenbar,
     *                 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
          it2fb(ivx,ifbadd) = it1xtup(nxtup)+nodur(ivx,cnn(ivx))+itgulp2
     *                         -lenbar
        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
          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
c
          call addfb(nfb,ivx,it1xtup(nxtup)+itgulp2-lenbar,
     *                 it1fb,it2fb,ulfbq,ifbadd)
        end if
      else if (inxtup) then
        inxtup = .false.
        n2xtup(nxtup) = in
        it2fb(ivx,ifbadd) = it1xtup(nxtup)+nodur(ivx,cnn(ivx))+itgulp2
     *                         -lenbar
      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
        isl = islur(list(1,min(in+1,ntot)),list(2,min(in+1,ntot)))
        if ( in.eq.ntot .or. ((list(1,min(in+1,ntot)).eq.1 .and. 
     *          (iand(isl,96).gt.0 
     *               .or. ornq(1,list(2,min(ntot,in+1))).eq.'g')) 
     *      .or. btest(isl,15) )) then
c
c  Bar end, segno, int. rpt, clef; flow out of if-loop and into block-wrapup      
c
          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     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     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  itgulp2 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.itgulp2) 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)-(itgulp2-lenbar)
            itbb2 = it2fb(ivx,ifb)-(itgulp2-lenbar)
            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
                do 84 ip1 = ip+1 , 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
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
        if (ornq(1,list(2,istart(ib))).eq.'g' .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
c       itrpt = 0
        itrpt = -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
        isacc = accq(ivx,ip) .ne. 'x'
c
c  Remember, rpts can only come at start of (internal) block
c
        if (ivx.eq.1 .and. iand(islur(ivx,ip),96).gt.0) then
          itrpt = list(3,in)
c          if (btest(islur(ivx,ip),5)) itdots = itrpt
c          if (iand(islur(ivx,ip),96) .gt. 0) itdots = itrpt
        end if
        isgrace = btest(islur(ivx,ip),4) 
        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))) 
        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 (isacc) accq(ivx,ip) = upcaseq(accq(ivx,ip))
            go to 111
          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 .and. 
     *      .not.rest(ivx,ip-1) .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) .and. 
     *     2**log2(max(1,nd)).ne.nd
c    *     2**log2(nd).ne.nd
c  (nd may=0 if ip=1)
c  Next line negates isdot if dotted item is xtuplet.
c
        if (isdot) isdot = ip.eq.2 .or. nodur(ivx,ip-2).gt.0
        
        if (.not.(isacc.or.isgrace.or.iscln.or.isflag.or.isdot)) 
     *                                                     go to 111
c
c  Here is an accid, grace, clef, flag, or dot. May need space. 
c
        pts = wheadpt
        if (isgrace) then
          do 122 ig = 1 , ngrace
            if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 123
122       continue
          print*,'Problem finding grace index'
          stop
123       continue
c
c  wgr is distance to backspace (in headwidths).  ptgr is same in pts.  
c  spgr is total space needed (w/o acc).  NB apt=wheadpt, don't get confused.
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 (isacc) ptgr(ig) = ptgr(ig) + accfac*wheadpt
          if (accgq(ngstrt(ig)) .ne. 'x') spgr = spgr+wheadpt*agc1fac
          pts = pts+spgr
c     print*,'+GRACE,ig,ptgr,pts,spgr->',ig,ptgr(ig),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 (isacc) ptclef(ivx) = ptclef(ivx)+accfac*wheadpt
          if (isgrace) ptclef(ivx) = ptclef(ivx)+spgr
c     print*,'+CLEF, ptclef, pts->',ptclef(ivx),pts
        end if
        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
        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
c     print*,'Passed that, isfirst,itrpt,list(3,in):',isfirst,itrpt,
c    *list(3,in)
          if (isfirst) then
c
c  At start of bar or after repeat sign
c
            esk = fbar
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     print*,'Xtup in prev block in some voice, esk:',esk
c     print*,'Xtup in prev block in this voice, esk:',esk
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) 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 (isacc) 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 111
        end if
        ptsneed = pts
        if (isacc) 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)
c     print*,'AddasK,pts,esk:',ptsneed,esk
c     print*
          else
            call addasx(ip,ivx,ptsneed,esk,fixednew,scaldold)
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
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.
c
        if (ib.gt.1 .and. list(1,istart(ib)).eq.1) then
          iirpt = iand(islur(1,list(2,istart(ib))),96)
          if (iirpt .gt. 0) then
            write(11,'(a)')sq//'advance'//sq//'barno-1%'
            if (iirpt .eq. 96) then
              write(11,'(a)')sq//'leftrightrepeat'
              fixednew = fixednew+lrrptfac*wheadpt
            else if (iirpt .eq. 32) then
              write(11,'(a)')sq//'leftrepeat'
              fixednew = fixednew+rptfac*wheadpt
            else 
              write(11,'(a)')sq//'rightrepeat'
              fixednew = fixednew+rptfac*wheadpt
            end if
            scaldold = scaldold-fbar
          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
c         if (iv .gt. 1) call addstr(sepsymq,1,soutq,lsout)
          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
            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
            if (list(3,jn) .gt. itnow) then   
              call addstr(sq//'sk',3,soutq,lsout)
              itnow = itnow+nspace(ib)
              go to 12
            end if
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))
                elasksys(nasksys) = elask(iaskb(ivx))
              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
              call addstr(litq(il),lenlit(il),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
              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)
              beamon(ivx) = .true.
              bspend = .true.
            end if
c
c  Check for ornaments.  ')' on dotted notes go in with note, not here.
c
            if (index('qg',ornq(ivx,ip)).eq.0 .and. (ornq(ivx,ip).ne.')'
     *            .or. 2**log2(nodur(ivx,ip)).eq.nodur(ivx,ip))) then
              if (ornq(iv,ip) .eq. ')') then
                ihorn = nolev(ivx,ip)
              else if (nornb(ivx) .ne. 0) then
c
c  In a beam, height has already been calculated
c
                ihorn = ihornb(ivx,nornb(ivx))
                nornb(ivx) = nornb(ivx)+1
              else if (udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
     *            nvmx(iv),ivx,nv).eq.'l' .or. nodur(ivx,ip).ge.64) then
c
c  Separate note, lower stem
c
                ihorn = max(ncmid(iv,ip)+5,nolev(ivx,ip)+2)
              else
c
c  Separate note, up stem, must clear the stem
c
                ihorn = max(ncmid(iv,ip)+5,
     *                      nolev(ivx,ip)+2+ni(stemlen-0.5))
              end if
              ioff = 0
              if (ornq(ivx,ip) .eq. 't') then
                notexq = sq//'shake'
                lnote = 6
              else if (ornq(ivx,ip) .eq. 'm') then
                notexq = sq//'mordent'
                lnote = 8
              else if (ornq(ivx,ip) .eq. 's') then
                notexq = sq//'mtr'
                lnote = 4
              else if (ornq(ivx,ip) .eq. 'x') then
                notexq = sq//'xtr'
                lnote = 4
              else if (ornq(ivx,ip) .eq. '+') then
                notexq = sq//'ptr'
                lnote = 4
              else if (ornq(ivx,ip) .eq. ')') then
                notexq = sq//'rpn'
                lnote = 4
              else if (ornq(ivx,ip) .eq. 'u') then
                notexq = sq//'upz'
                lnote = 4
                ioff = -2
              else if (ornq(ivx,ip) .eq. 'p') then
                notexq = sq//'uppz'
                lnote = 5
                ioff = -2
              else if (ornq(ivx,ip) .eq. 'f') then
                if (nodur(ivx,ip) .lt. 48) then
                  notexq = sq//'fermataup'
                else
                  notexq = sq//'Fermataup'
                end if
                lnote = 10
                ioff = -2
              end if
              call notefq(noteq,lnoten,ihorn+ioff,ncmid(iv,ip))
              if (lnoten.eq.1) call addblank(noteq,lnoten)
              if (index('TU',ornq(ivx,ip)) .gt. 0) then
                call dotrill(ivx,ip,ornq(ivx,ip),noteq,lnoten,
     *                 notexq,lnote)
              else 
                notexq = notexq(1:lnote)//noteq(1:lnoten)
                lnote = lnote+lnoten
              end if
              call addstr(notexq,lnote,soutq,lsout)
            end if
c
c  Is there slur or grace activity?
c
            if (iand(islur(ivx,ip),31) .ne. 0) then
              islur1 = iand(islur(ivx,ip),3)
              if (islur1 .gt. 0) then
                if (ivx .eq. nv) then
c
c  slur1 (type s) in voice n (top line).  Keep track to set height of barno
c 
                  if (islur1 .eq. 2) then
                    is1n1 = 0
                  else 
                    is1n1 = nolev(ivx,ip)
                  end if
                end if
                call doslur(islur(ivx,ip),nolev(ivx,ip),ncmid(iv,ip),
     *           beamon(ivx),iv,nv,1,ulq(ivx,ibmcnt(ivx)),soutq,lsout,
     *           ipl(ivx,ip))
              end if
              islur2 = iand(ishft(islur(ivx,ip),-2),3)
              if (islur2 .gt. 0) then
                if (ivx .eq. nv) then
c
c  slur2 (type t) in voice n.  Keep track to set height of barno
c 
                  if (islur2 .eq. 2) then
                    is2n1 = 0
                  else
                    is2n1 = nolev(ivx,ip)
                  end if
                end if
                ifactor = 1
                if ((btest(islur1,0).and.btest(islur2,0)) .or.
     *              (btest(islur1,1).and.btest(islur2,1))) 
     *              ifactor = -1
c
c Type 't' slur is starting or ending on same note as type 's'; send a signal
c  by making nolev < 0
c
                islur1 = iand(not(3),islur(ivx,ip))
                call doslur(ior(islur1,islur2),nolev(ivx,ip)*ifactor,
     *            ncmid(iv,ip),beamon(ivx),iv,nv,2,ulq(ivx,ibmcnt(ivx)),
     *            soutq,lsout,ipl(ivx,ip))
              end if
              if (btest(islur(ivx,ip),4)) then 
c
c Grace note
c
                call dograce(ivx,ip,ptgr,
     *                 soutq,lsout,ncmid(iv,ip),accq(ivx,ip),ig)
                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(ivx,2),0,ncmid(iv,ip),soutq,lsout)
                end if
              end if
            end if   
c
c  Accidentals
c
            if (accq(ivx,ip) .ne. 'x') then
              notexq = sq
              lnote = 1
              if (ichar(accq(ivx,ip)) .le. 90) then 
                notexq = sq//'big'
                lnote = 4
              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
              call addstr(notexq,lnote,soutq,lsout)
            end if             
c
c  Check for chord notes  
c
            if (btest(ipl(ivx,ip),10)) then
              call docrd(ivx,ip,nodur(ivx,ip),ncmid(iv,ip),notexq,lnote)
              call addstr(notexq,lnote,soutq,lsout)
            end if
c
c  Is a beam start pending?
c
            if (bspend) 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
              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 (rest(ivx,ip) .and. nodur(ivx,ip).eq.lenbar
     *     .and..not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)) then
              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)) 
     *           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)
            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) .and. 
     *          nspace(ib).lt.16 ) then
c
c  Non-xtup, in last nspace, smaller than a quarter note.
c
              if ((.not.rest(ivx,ip) .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
            end if
c            flgndv(ivx) = .not.vxtup(ivx) .and. 
c     *           nodur(ivx,ip).eq.nspace(ib) .and. 
c     *          ( (nspace(ib).lt.16 .and. .not.rest(ivx,ip) .and.
c     *           udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
c     *             nvmx(iv),ivx,nv).eq.'u'
c     *        .and. (numbms(ivx).eq.0 .or. ip.gt.ibm2(ivx,numbms(ivx))))
c     *         .or. 2**log2(nodur(ivx,ip)).ne.nodur(ivx,ip) )
            flgndb = flgndb .or. flgndv(ivx).gt.0.
          end if
          xtupb4 = xtupb4 .or. vxtup(ivx)
          vxtup(ivx) = .false.
          xtfold(ivx) = xtupfac(ivx)
11      continue
        call addstr(sq//'en',3,soutq,lsout) 
        if (lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%'
16    continue           
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
          if (lsout .eq. 0) then
c           if (ibar .ne. ibarmbr) write(11,'(a)')sq//'def'//sq//
c    *              'wbrest{'//sq//'centerbar'//cwrq(1:lcwr)//'}%'
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)
              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
c             soutq = soutq(1:lsout)//sepsymq(iv-1)
              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 defnotes(iemin,iemax)
c
c note  64 .64  32 .32  16 .16  8  .8   4   .4   2  .2   0  .0
c index 1   2   3   4   5   6   7   8   9   10  11  12  13  14  
c time  1   x   2   3   4   6   8   12  16  24  32  48  64  96  
c
      character*79 notexq
      character*6 nstartq(14)
      common /comstart/ nstartq,lstart(14),facmtr
      do 2 index = iemin , iemax
        if (index .eq. 2) go to 2
        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}%'
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'
        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),
     *                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
      character*80 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 withing 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
          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
          notexq = sq//'off{'
          if (-offnsk .lt. -9.95) then
            write(notexq(6:10),'(f5.1)')-offnsk
            lnote = 10
          else if (-offnsk.lt.-.95 .or. -offnsk.gt.9.95) then
            write(notexq(6:9),'(f4.1)')-offnsk
            lnote = 9
          else if (-offnsk.lt.-.001 .or. -offnsk.gt..95) then
            write(notexq(6:8),'(f3.1)')-offnsk
            lnote = 8
          else
            write(notexq(6:7),'(f2.1)')-offnsk
            lnote = 7
          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
c
c  Figure is a single number
c
          call addstr(sq//'Figu{'//nofq(1:lnof)//'}{'//ch1q//'}',
     *           10+lnof,soutq,lsout)      
        end if
        ic = ic+1
        nof = nof+4
        nofa = nofa+4  
        go to 1
2     continue
      if (abs(offnsk) .gt. .0001) then
        notexq = sq//'off{'
        if (offnsk .lt. -9.95) then
          write(notexq(6:10),'(f5.1)')offnsk
          lnote = 10
        else if (offnsk.lt.-.95 .or. offnsk.gt.9.95) then
          write(notexq(6:9),'(f4.1)')offnsk
          lnote = 9
        else if (offnsk.lt.-.001 .or. offnsk.gt..95) then
          write(notexq(6:8),'(f3.1)')offnsk
          lnote = 8
        else
          write(notexq(6:7),'(f2.1)')offnsk
          lnote = 7
        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
      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
      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,ornq,noteq,lnoten,notexq,lnote)
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(43)
      character*1 ornq
      character*8 noteq
      character*79 notexq
      logical tronly 
      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
      else if (ornq .eq. 'T') 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(iv,ip,nodu,ncmid,notexq,lnote)
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(43)
      character*4 nosymq
      character*13 accstrq 
      character*8 noteq
      character*79 notexq
      logical found1,btest,isleft,isright
      data accstrq /'naflshdfl dsh'/
c
c  This subr. produces notexq for entire chord
c  Find the chord in list. Chord notes will be consecutive in list. 
c
      found1 = .false.
      lnote = 0
      do 1 icrd = 1 , ncrd
        if (iand(255,icrdat(icrd)) .eq. ip  .and.
     *      iand(15,ishft(icrdat(icrd),-8)) .eq. iv) then
          isleft = btest(icrdat(icrd),23)
          isright = btest(icrdat(icrd),24)
c
c  get duration indicator, no longer good for all notes of chord (shifts!)
c 
          if (nodu .eq. 96) then
            nosymq = char(92)//'zwp'
            lsym = 4
          else if (nodu .eq. 64) then
            if (isleft) then
              nosymq = char(92)//'lw'
            else if (isright) then
              nosymq = char(92)//'rw'
            else
              nosymq = char(92)//'zw'
            end if
            lsym = 3
          else if (nodu .eq. 48) then
            nosymq = char(92)//'zhp'
            lsym = 4
          else if (nodu .eq. 32) then
            if (isleft) then
              nosymq = char(92)//'lh'
            else if (isright) then
              nosymq = char(92)//'rh'
            else
              nosymq = char(92)//'zh'
            end if
            lsym = 3
          else if (2**log2(nodu) .ne. nodu) then
            nosymq = char(92)//'zqp'
            lsym = 4
          else
            if (isleft) then
              nosymq = char(92)//'lq'
            else if (isright) then
              nosymq = char(92)//'rq'
            else
              nosymq = char(92)//'zq'
            end if
            lsym = 3
          end if
c
c  Check for accidental
c
          if (btest(icrdat(icrd),19)) then
c
c  Get note name
c
            call notefq(noteq,lnoten,
     *                iand(ishft(icrdat(icrd),-12),127),ncmid)
            if (lnoten.eq.1) call addblank(noteq,lnoten)
c           iacc = 2*ishft(icrdat(icrd),-20)
            iacc = 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
            if (lnote .gt. 0) then
              notexq = notexq(1:lnote)//char(92)//accstrq(iacc:i2acc)
     *                 //noteq(1:lnoten)//nosymq
            else
              notexq = char(92)//accstrq(iacc:i2acc)
     *                 //noteq(1:lnoten)//nosymq
            end if
            lnote = lnote+1+lacc+lnoten
          else
c
c  No accidental
c
            if (lnote .gt. 0) then
              notexq = notexq(1:lnote)//nosymq
            else
              notexq = nosymq
            end if
          end if
          lnote = lnote+lsym
c
c  Get note name (again if accid, due to possible ocatave jump)
c
          call notefq(noteq,lnoten,
     *                iand(ishft(icrdat(icrd),-12),127),ncmid)
          if (lnoten.eq.1) call addblank(noteq,lnoten)
c
c  Put in note name
c
          notexq = notexq(1:lnote)//noteq
          lnote = lnote+lnoten
        else if (found1) then
c
c  No more checking needed, leave the loop
c
          go to 2
        end if
1     continue
2     continue
      return
      end
      subroutine dograce(ivx,ip,ptgr,soutq,lsout,ncm,acciq,ig)
c
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),
     *                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,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac 
      common /comask/ bar1syst,fixednew,scaldold,apt,abigpt,
     *                wheadpt,fbar,poenom
      common /comslur/ listslur,ndxslur(nm,2),upslur(nm,2)
      logical upg,slurg,slashg,bar1syst,upslur
      real*4 ptgr(37)
      character*80 soutq,litq
      character*79 notexq
      character*10 voltxtq
      character*8 noteq
      character*3 acsymq
      character*1 accgq,acciq,sq
      sq = char(92)
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'
      stop
121   continue
      ngs = ngstrt(ig)
      mg = multg(ig)
      if (slurg(ig)) then
        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(ivx,2) = log2(511-listslur)
c
c  Turn on slur level 2.  May not need this if we terminate slur right away.
c
c       listslur = ibset(listslur,ndxslur(ivx,1))
      end if
      if (nng(ig) .eq. 1) then
c
c  Single grace.  Start with lshift function
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
        if (slurg(ig)) 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(ivx,2))//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)
        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{-'
        write(notexq(20:23),'(f4.1)')ptgr(ig)
        call addstr(notexq(1:23)//'pt}',26,soutq,lsout)
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?
c
        if (slurg(ig)) 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(ivx,2))//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
          notexq = sq//'off{'
          write(notexq(6:8),'(f3.1)')ptoff
          call addstr(notexq(1:8)//'pt}',11,soutq,lsout)
c
c  Terminate if needed
c
          if (ing .eq. ngs+nng(ig)-1) then
            if (upg(ig)) then
              call addstr(sq//'tbu0',5,soutq,lsout)
            else
              call addstr(sq//'tbl0',5,soutq,lsout)
            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 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{'
        ptoff = wheadpt*emgfac
        if (acciq .ne. 'x') ptoff = ptoff+wheadpt*accfac
        if (ptoff .lt. 9.95) then
          write(notexq(21:23),'(f3.1)')ptoff
          lnote = 23
        else
          write(notexq(21:24),'(f4.1)')ptoff
          lnote = 24
        end if
        call addstr(notexq(1:lnote)//'pt}',lnote+3,soutq,lsout)
      end if
      return
      end
      subroutine wsclef(iv,nv,noinst,clefq,nclef)
      parameter (nm=7)
      character*1 clefq(nm)
      character*12 temq
      if (nv.eq.noinst .or. iv.gt.nv-noinst+1) then
        ioff = nv-noinst
        write(11,'(a)')char(92)//'setclef'//char(48+iv-ioff)//
     *                 char(48+nclef)//'%'
      else
        clefq(iv) = char(48+nclef)
        temq = '{'
        ltem = 1
        do 1 iiv = 1 , nv-noinst+1
          temq = temq(1:ltem)//char(48+numclef(clefq(iiv)))
          ltem = ltem+1
1       continue
        write(11,'(a)')char(92)//'setclef1'//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)
      logical isfig
      character*1 charq
      character*6 figq
      character*128 lineq
      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(74),iline,figbass,figcheck,firstgulp,rest(nm,200),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,accq(nm,200),ulq(nm,8),
     *   ornq(nm,200)
      character*1 accq,ulq,ornq,sepsymq,sq
      logical beamon,rest,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
