File: pmxab.for

package info (click to toggle)
pmx 2.2.0-1
links: PTS
area: contrib
in suites: potato
size: 1,876 kB
ctags: 1,026
sloc: sh: 109; makefile: 64
file content (16340 lines) | stat: -rw-r--r-- 530,240 bytes
      program pmxab
ccccccccccccccccccccccccc
c
c  pmxab, Version 2.2 (p2197) March 18, 2000
c
ccccccccccccccccccccccccc
c
c To do
c
c   Transpose by instruments
c   Beams with single 64ths
c   128ths and/or dotted 64ths
c   Close out MIDI with integral # of beats?
c   Increase ast dimensions or redo logic.
c   Does slur direction get set for user-defined single-note stem dir'ns?
c   Transpose by sections.
c   Loop over sections only
c   Command-line option to read nbarss in.  Write out nbarss when optimizing.
c     (or just read from .plg?)
c   Beams over bar lines.
c   2-digit figures
c   Repeated ornaments retain offset info.
c   Unbeamed xtups.
c   A real coule (slanted line between notes in a chord)
c   Clean up dynamic marks.  (Add description in ref200!)
c   Dotted slurs for grace notes.
c   Undotted chord notes with dotted main note.
c   Forced line break without line #.
c 2.197
c   add /comips/ to save tie-check midi variables
c   For spacing of clef changes at start of input block, changed integer time
c     lastnodur to prevtn, so it works with xtups. Possible incompatibility!
c 2.196
c   Fix Ickbug with time check in ncmid()
c   Interchange \fermataup7 and \pausec to get proper alignment
c   Enable French violin clef "f",  number 7 in PMX, but 9 in MusiXTeX.
c   Add defn's of \hsp, \hspp to pmx.tex 
c   Fix pre-slurs on xtup chord notes.
c   Fixed raised PAuse, define \liftPAuse
c   Replace \zbreve\sk with \breve.
c   Made "1" work as mtrdenl by doubling it and mtrnuml
c     BUT WAIT...what about "o" and 1 as shorthand for 16???? Search for "Kluge"
c   Added "vo" (voice) as MIDI instrument 55 
c   Allow 3-digit page numbers (search for "toppageno")
c   Fix bug caused by prior fix (cancelling accid after bar line was ignored).
c   Fix double accids in chords
c 2.194
c   Fix bug with accid/tie/barline/chord in addmidi by restructuring accid if 
c     block.
c   Add meter to MIDI file with every pause
c   Purify FORTRAN?
c 2.193
c   Increased # of in-line TeX strings from 36 to 52.
c   Fix entry of # of bytes in header of tempo/meter/key track to allow >255.
c 2.191
c   Event track: Tempos, meters, keys all together.  Data in comevent
c 2.15
c   Pretty good midi capability.  Still no attention to slurs on chord notes.
c 2.11
c   11 Dec 99 c   rm1
c   11 Dec 99 "oes?", "oe?"
c   11 Dec 99 Cancel slur horizontal tweaks with non-stemmed notes
c   11 Dec 99 Error message for shifted, repeated ornaments.
c 2.10 (Version 2.1)
c   Fix bug with lowdot and xtuplets
c 2.09
c   Fix bug with multiple ornament heights over beams, when one is . or _
c   Error message from pmxa if rest on last note of xtup.
c   Enable 12 slurs.
c   Reinstate multiple rests at start of xtup.
c 2.07
c   Combine consecutive type-1 TeX strings.
c   \midslur and \curve as 3rd signed digit in slur termination, + 2 opt. int's.
c   Fixed breve chord notes in docrd
c   Check irest(28) as well as vxtup when setting nodur for chord notes, since
c     vxtup isn't set until 1st *main* note in xtup
c   Vectorize nolev1, slope, ixrest.  Klug fix for xtups with variable spacing.
c 2.06+
c   Make deterministic the beam slope calculation when there are an even # of
c     slopes in list and middle two are equal magnitude but opposite sign.
c   pmxa Trap for "o:" before 1st note in block
c   Partial bug fix for 64th notes in xtuplets.
c   Make ixrest a vector, since with new time scheme may not finish xtup in
c     same notes block.
c   Increase max # of pages from 20 to 30 (dimensions of nsystp,..., in pmxb)
c
c 2.06
c   Account for changes in nv when computing \interstaff. Add a counter 
c     nistaff(iflb) = # of interstaff spaces per system = nv-1.  Set whenever
c     setting isysflb(iflb). Note nv can only change at a forced line break.  
c     Note also, iflb starts at 0!
c
c 2.05
c   Automatic start of new notes group with part 2 of staff-jump beam
c     In make1bar, set irest bit 29 of lowest-voice note at same time,
c     use as flag when making notes groups.
c   For now, remove dummy blank line at end...it zaps terminal repeats.
c
c 2.02
c   Fixed slur-counting bug for multiple, slurred, aftergraces.
c 2.01
c  Increase to ask(1400)
c  Increase max forced page breaks to 18
c  Define pausc for centered pause
c
c 2.0a
c  Insert dummy blank line at very end to handle input files w/o terminal CR-LF
c
c pmx03r
c   Option m[n] in S symbol to change musicsize (for parts)
c   Double dotted rests now work.
c   Write file name to log file
c   Check existence of input file
c   Allow 24-char jobname, may end with ".pmx"
c   Comment out time stuff
c   Replace 3-argument getarg with 2-argument + iargc
c   Fix bug with negative noinst due to nint<=int replacement
c   move lovation of iv in isdat1 to allow iv>7.
c   Set nm=12 
c pmx03q
c   replace int(x+.001) with nint(x)
c   Write TeX file name to screen and to pml.
c   Replace char(...) with chax(...) to sovle msdev bug.
c   Bug fix: macro terminations when M is on a line by itself.
c   Bug fix: don't accumulate space for XS in pmxa.
c   Streamline Macros: use pointers to bufq instead of scratch files
c pmx03p
c   Store input file in single character array bufq. 
c     lbuf(i)*2 is length of line i
c     ipbuf is position just before next line to be read.
c pmx03
c   Optimize read/writes
c pmx02
c   Fix line count (for errors) when there are saved macros
c pmx01
c   In optimize mode, open/close macros (Watch out for residual zz files!)
c   Command line input
c   Option Ao to optimize, otherwise normal processing
c
ccccccc
      parameter (nks=125,nm=12,mv=24576)
      character*128 lnholdq
      character*65536 bufq
      integer*2 lbuf(2000)
      common /comevent/ miditime,lasttime
      logical slmon,dbltie
      common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
     *       naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
     *       slmon(0:nm),dbltie
      integer*2 mmidi
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
      common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
      common /commus/ musize,whead20
      integer*4 nbars0(nks),nbars(nks),ipoe(nks),nbari(nks)
      real*4 poe0(nks),poe(nks)
      logical isfirst,optimize
      logical*4 fexist
      character*24 jobname
      character*27 infileq
      common /a1ll/ iv,ivxo(200),ipo(200),to(200),tno(200),nnl(nm),
     *   nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
     *   idum,itsofar(nm),nib(nm,15),nn(nm),
     *   rest(nm,200),lenbr0,lenbr1,firstline,newmeter
      logical rest,firstline,newmeter
      common /comdiag/ n69(0:nm)
      logical mmacrec,gottempo
      common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
     *       mmactime(20),nmidsec,msecstrt(0:nm,20),msecend(0:nm,20),
     *       mmacrec,gottempo
c
c  immac(i) is the index of i-th macro, i=1,nmac.  Also make a list containing
c   nmidsec  section starts and stops based on PLAYING macros (not recording).
c 
      data maxit,ncalls /200,0/
      data isfirst /.true./
c      itstart = mytime()
c
c  Initialize midi parameters
c
      gottempo = .false.
      ismidi = .false.
      relacc = .false.
      mmacrec = .false.
      nmidsec = 1
      mgap = 10
      miditime = 0
      lasttime = 0
      nmidcrd = 0
      nusebl = 0
      notmain = .false.
      do 3 ivx = 1 , nm
        twoline(ivx) = .false.
        midinst(ivx) = 6
3     continue
      do 12 icm = 0 , nm
        imidi(icm) = 0
        restpend(icm) = .false.
        trest(icm) = 0.
        levson(icm) = 0
        levsoff(icm) = 0
        slmon(icm) = .false.
        naccbl(icm) = 0
        n69(icm) = 0
        msecstrt(icm,1) = 1
12    continue
c
c  End of midi parameter initialization
c
      musize = 0
      optimize = .false.
      numargs = iargc()
      if (numargs .eq. 0) then
        print*,'You could have entered a jobname on the command line,'
        print*,'      but you may enter one now:'
        read(*,'(a)')jobname
        numargs = 1
      else 
c        call getarg(1,jobname,idum) ! May need to replace this w/ next line 
        call getarg(1,jobname) 
      end if
10    ljob = lenstr(jobname,24)
      if (ljob .gt. 24) then
        print*,'Jobname is too long. Try again.'
        stop 1
      else if (ljob .eq. 0) then
        print*,'No was jobname entered. Try again.'
        stop 1
      else if (numargs .eq. 2) then
        if (ljob.eq.2 .and. jobname(1:2).eq.'-o') then
          optimize = .true.
c          call getarg(2,jobname,idum) ! May need to replace this w/ next line 
          call getarg(2,jobname) 
          numargs = 1 
          go to 10
        else
          print*,'Illegal option on command line'
          stop 1
        end if
      end if
c
c  Strip ".pmx" if necessary
c
      ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX'))
      if (ndxpmx .gt. 0) then
        jobname = jobname(1:ndxpmx-1)
        ljob = ljob-4
      end if
c
c  Check for existence of input file
c
      infileq = jobname(1:ljob)//'.pmx'
      inquire(file=infileq,EXIST=fexist)
      if (.not.fexist) then
        print*,'Cannot find file '//infileq
        stop 1
      end if
c
c  Open a log file
c
      open(15,file=jobname(1:ljob)//'.pml')
      call printl('This is pmxab, version 2.2, 18 March 2000')
      ljob4 = ljob
      call printl('Opening '//infileq)
      open(18,file=infileq)
c
c  Copy input file into common buffer 
c
      ipbuf = 0
      do 8 ilbuf = 1 , 2000
        read(18,'(a)',end=9)lnholdq
        lbuf(ilbuf) = lenstr(lnholdq,128)
        if (lbuf(ilbuf) .eq. 0) then
c
c  Blank line.  Make it a single blank with length 1
c
          lbuf(ilbuf) = 1
          lnholdq = ' '
        end if
        bufq(ipbuf+1:ipbuf+lbuf(ilbuf)) = lnholdq
        ipbuf = ipbuf+lbuf(ilbuf)
8     continue
      call printl('Too many lines in input file')
      stop 1
9     continue
c
c  Insert dummy line to handle input files w/o CR-LF at end.
c
      nlbuf = ilbuf-1
c      nlbuf = ilbuf
c      bufq(ipbuf+1:ipbuf+3) = ' / '
c      lbuf(nlbuf) = 3
      close(18)
      do 6 numit = 1 , maxit
        if (optimize) call printl('Starting an iteration')
c
c  When isfirst=.true., pmxa() generates linebreaks normally, output in nbars0.
c    Otherwise, nbars0 is the input
c  When islast=.false., pmxb only returns poe's, otherwise does whole job
c
        call pmxa(jobname,ljob4,isfirst,nsyst,nbars0,optimize)
        if (.not.optimize) then
          if (ismidi) then
c
c  Set up channel numbers for midi. 
c
            numchan = 0
            do 11 iv = nv , 1 , -1
              if (twoline(iv)) then
                midchan(iv,2) = numchan
                numchan = numchan+1
              end if
              midchan(iv,1) = numchan
              numchan = numchan+1
11          continue     
          end if
c
c  numchan will now be the number of channels, but max channel # is numchan-1
c
          call pmxb(.true.,poe0,ncalls,optimize)
          if (ismidi) then
c
c  Write midi file
c
            open(51,file=jobname(1:ljob)//'.mid')
            call printl(' ')
            call printl('Writing '//jobname(1:ljob)//'.mid')
            call writemidi(jobname,ljob)
          end if
          close(15)
          stop
        end if
        call pmxb(.false.,poe0,ncalls,optimize)
        call poestats(nsyst,poe0,poebar0,devnorm0)
c
c  Save initial deviation and line breaks for later comparison
c
        if (numit .eq. 1) then
          devpmx = devnorm0
          do 20 isys = 1 , nsyst 
            nbari(isys) = nbars0(isys)
20        continue
        end if
        call sortpoe(nsyst,poe0,ipoe)
        do 1 iupord = nsyst , 1 , -1
          isysu = ipoe(iupord)
          print*,'isysu=',isysu
          write(15,*)'isysu=',isysu
c
c  Skip if system isysu has poe0 < avg or isysd has poe0 > avg
c
          if (poe0(isysu).lt.poebar0) go to 1
          do 5 idnord = 1 , nsyst
            isysd = ipoe(idnord)
            if (isysu.eq.isysd .or. nbars0(isysd).eq.1
     *                     .or. poe0(isysd).gt.poebar0) go to 5
            do 2 isyst = 1 , nsyst
              nbars(isyst) = nbars0(isyst)
              if (isyst .eq. isysu) then
                nbars(isyst) = nbars(isyst)+1
              else if (isyst .eq. isysd) then
                nbars(isyst) = nbars(isyst)-1
              end if
2           continue
            call pmxa(jobname,ljob4,isfirst,nsyst,nbars,optimize)
            call pmxb(.false.,poe,ncalls,optimize)
            call poestats(nsyst,poe,poebar,devnorm)
            if (devnorm .lt. devnorm0) then
              devnorm0 = devnorm
              poebar0 = poebar
              do 4 isys = 1 , nsyst
                nbars0(isys) = nbars(isys)
                poe0(isys) = poe(isys)
4             continue
              print*,'Improved with iup,idown,devnorm:',
     *                 isysu,isysd,devnorm0
              write(15,*)'Improved with iup,idown,devnorm:',
     *                 isysu,isysd,devnorm0
              write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
              write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
              call sortpoe(nsyst,poe0,ipoe)
              go to 6
            end if
5         continue
1       continue
c
c  If we get here, must have gone thru all switches and found nothing better,
c  so done!
c
        go to 7
6     continue
7     continue
      print*,'Optimum located, numit:',numit,',  ncalls:',ncalls
      write(15,*)'Optimum located, numit:',numit,',  ncalls:',ncalls
      print*,'Final error:',devnorm0,', initial error:',devpmx
      write(15,*)'Final error:',devnorm0,', initial error:',devpmx
      print*,'Percentage improvement:',100.*(1-devnorm0/devpmx)
      write(15,*)'Percentage improvement:',100.*(1-devnorm0/devpmx)
      call printl('Initial bars/system:')
      write(*,'(5x,20i3)')(nbari(isys),isys=1,nsyst)
      write(15,'(5x,20i3)')(nbari(isys),isys=1,nsyst)
      call printl('Final bars/system:')
      write(*,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
      write(15,'(5x,20i3)')(nbars0(isys),isys=1,nsyst)
      call pmxa(jobname,ljob4,.false.,nsyst,nbars0,optimize)
      call pmxb(.true.,poe0,ncalls,optimize)
c      itend = mytime()
c      print*,'Elapsed time in ms:',itend-itstart
c      write(15,*)'Elapsed time in ms:',itend-itstart
      close(15)
      end
      subroutine poestats(nsyst,poe,poebar,devnorm)
      parameter (nks=125)
c
c  Compute avg. & norm. std. dev. of poe.
c
      real*4 poe(nks)
      sumx = 0.
      sumxx = 0.
      do 1 isyst = 1 , nsyst
        sumx = sumx+poe(isyst)
        sumxx = sumxx+poe(isyst)**2
1     continue
2     continue
      devnorm = sqrt(nsyst*sumxx/sumx**2-1)
      poebar = sumx/nsyst
      return
      end
      subroutine sortpoe(nsyst,poe,ipoe)
      parameter (nks=125)
      real*4 poe(nks)
      integer*4 ipoe(nks)
c
c  Initialize ipoe:
c
      do 3 iord = 1 , nsyst
        ipoe(iord) = iord
3     continue
c
c  Construct ipoe vector with pairwise interchanges.  When done, ipoe(1) will
c  be index of smallest poe, and ipoe(nsyst) will be index of biggest poe.
c
      do 4 io1 = 1 , nsyst-1
        do 5 io2 = io1+1 , nsyst
          if (poe(ipoe(io1)) .gt. poe(ipoe(io2))) then
c
c Interchange the indices
c
            itemp = ipoe(io1)
            ipoe(io1) = ipoe(io2)
            ipoe(io2) = itemp
          end if
5       continue
4     continue
      return
      end
      subroutine pmxa(basenameq,lbase,isfirst,nsyout,nbarss,optimize)
cccccccccccccccccccccccccccccccccccccccccccccccc
cc                                            cc
cc Subroutine, combine with pmxb.for
cc
cccccccccccccccccccccccccccccccccccccccccccccccc
cc
cc  Need to consider X spaces in xtuplets when getting poenom, and
cc      maybe fbar?
cc  mx06a
cc    ID numbers for voices when number of voices is reduced.
cc
cc  mx03a
cc    account for new fracindent for new movements.
cc
cc  Known changes since pmxa. Version 1.1b (see pmxb for longer list)
cc
cc  Check ID codes for slurs.
cc  Version 1.24 still does not have details for spacing/positioning
cc    arpeggios if there are accidentals or shifted notes or crowded scores.
cc  Fix problem in 1.22 with arpeggios across multi-line staves
cc  Fix problem in 1.22 with flat key signatures
cc  Read setup data as strings
cc  Warning for octave designation plus +/-
cc  Don't pause for volta warning,
cc  Macros
cc  Correct fsyst to account for transposition and key changes.
cc  Check for nbars > nsyst
cc
ccccccccccccccccccccccccccccccccccc
      parameter (nm=12,nkb=600,nks=125)
      logical loop,usefig,isfirst,optimize
      character*65536 bufq
      integer*2 lbuf(2000)
      common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
      integer nn(nm),nodur(nm,200),ivxo(200),ipo(200),
     *        nnl(nm),itsofar(nm),nib(nm,15),lastbar(0:nks),nbarss(nks)
      common /c1omnotes/ nnodur,wminnh(nkb),nnpd(2000),durb(2000),iddot,
     *     nptr(nkb),ibarcnt,mbrest,ibarmbr,
     *     ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(2000)
      common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40),
     *      isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
     *      usefig,fintstf,gintstf,fracsys(20),nmovbrk,isysmb(0:20),
     *      nistaff(0:40)
      common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1,
     *       kchmid(18),ornrpt,shifton,barend,noinst
      real*4 elsk(nkb),celsk(0:nkb),elss(nks),to(200),tno(200)
      character*128 lnholdq
      character*24 basenameq
      logical rest(nm,200),firstline,fbon,isvolt,iskchb,kchmid,ornrpt
      common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
     *     fracindent,nsperi(nm)
      logical lastchar,newmeter,newmb(nkb),issegno,bottreb,isheadr,
     *     shifton,barend
      common /a1ll/ iv,ivxo,ipo,to,tno,nnl,nv,ibar,mtrnuml,
     *   nodur,lenbar,iccount,nbars,itsofar,nib,nn,
     *   rest,lenbr0,lenbr1,firstline,newmeter
      common /linecom/ elskb,tnminb(nkb)
      common /cblock/
     *      etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
     *      xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh
      common /cominbot/ inbothd
      common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      common /commus/ musize,whead20
      common /comeon/ eonk,ewmxk
      logical mrecord,mplay,endmac,gotclef
      data wtimesig,wclef,wkeysig
     *   / 0.72  , 0.8 ,  0.28 /
      whead20 = 0.3
      if (.not.optimize) then
        print*
        print*,'Starting first PMX pass'
        write(15,'(a)') ' Starting first PMX pass'
      end if
      if (isfirst) then
        open(19,file='pmxaerr.dat')
        write(19,'(i6)') 0
        close(19)
      end if
      if (.not.optimize) jprntb = 81
      macuse = 0
      ornrpt = .false.
      mrecord = .false.
      mplay = .false.
      lastchar = .false.
      do 42 ibarcnt = 1 , nkb
        udsp(ibarcnt) = 0.
        wminnh(ibarcnt) = -1.
42    continue
c
c  Initialize input buffer
c
      ilbuf = 1
      ipbuf = 0
      call g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
     *    xmtrnum0,newkey(1),npages,nsyst,musize,bottreb)
c
c  Save initial meter for midi
c
      if (.not.isfirst .and. npages.eq.0) then
        print*,'Sorry, must have npages>0 for optimization.'
        stop 1
      end if
      nsyout = nsyst
c
c  isig1 will be changed in getnote if there is a transposition
c
      isig1 = newkey(1)
      if (npages .gt. nsyst) then
        call printl('npages > nsyst in input.  Please fix the input.')
        stop 1
      end if
c
c  fbar = afterruleskip/elemskip
c  apt = width of small accidental + space in points (= 6 at 20pt) =wheadpt
c
      fbar = 1.
      wheadpt = whead20*musize
      ifig = 0
      usefig = .true.
      lenbeat = i1fnodur(mtrdenl,'x')
      lenmult = 1
      if (mtrdenl .eq. 2) then
        lenbeat = 16
        lenmult = 2
      end if
      lenbr1 = lenmult*mtrnuml*lenbeat
      lenbr0 = nint(lenmult*xmtrnum0*lenbeat)
      mtrnuml = 0
      if (lenbr0 .ne. 0) then
        ibaroff = 1
        lenbar = lenbr0
      else
        ibaroff = 0
        lenbar = lenbr1
      end if
      ibarcnt = 0
      nptr(1) = 1
      iccount = 128
      nmovbrk = 0
      nflb = 0
      nfpb = 0
      ipagfpb(0) = 1
      isysfpb(0) = 1
      ibarflb(0) = 1
      isysflb(0) = 1
      nistaff(0) = nv-1
c
c  Initialize for loop over lines
c
      nkeys = 1
      ibrkch(1) = 1
      shifton = .false.
      firstline = .true.
      newmeter = .false.
      ihead = 0
      isheadr = .false.
      gotclef = .false.
      idsig = 0
      iddot = 0
      fintstf = -1.
      gintstf = 1.0
30    loop = .true.
      iskchb = .false.
      issegno = .false.
      nbars = 0
      ibarmbr = 0
3     do 4 iv = 1 , nv
        nvmx(iv) = 1
        ivmx(iv,1) = iv
        itsofar(iv) = 0
        nnl(iv) = 0
        do 5 j = 1 , 200
          rest(iv,j) = .false.
5       continue
4     continue
      iv = 1
      ivx = 1
      fbon = .false.
      barend = .false.
      isvolt = .false.
2     if (loop) then
c
c  Within this short loop, nv voices are filled up for the duration of a block.
c  On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv)
c  nodur(..),rest(..).  nnl will later be
c  increased and things slid around as accidental skips are added.
c
        call g1etnote(loop,ifig,optimize)
        if (lastchar) go to 20
        go to 2
      end if
      do 10 ibar = 1 , nbars
        ibarcnt = ibarcnt+1
c
c  The following is just a signal to start a new bar when cataloging spaces 
c    for catspace(...)
c
        nptr(ibarcnt+1) = nptr(ibarcnt)
        newmb(ibarcnt) = .false.
        if (newmeter.and.ibar.eq.1) newmb(ibarcnt) = .true.
c
c  Above is only for spacing calcs later on.  Remember new meter can only occur
c  at START of a new input line (ibar = 1)
c
        if (ibar .ne. ibarmbr) then
          if (.not.optimize) call outbar(ibarcnt-ibaroff,jprntb)
        else
          if (.not.optimize) then
            write(15,'(/,a19,i4,a1,i4)')' Multibar rest, bars',
     *        ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1
            write(*,'(/,a19,i4,a1,i4)')' Multibar rest, bars',
     *        ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1
            jprntb = 0
          end if
          ibaroff = ibaroff-mbrest+1
        end if
        if (firstline .and. lenbr0.ne.0) then
          if (ibar .eq. 1) then
            lenbar = lenbr0
          else
            lenbar = lenbr1
          end if
        end if
        if (ibar .gt. 1) then
c
c  For bars after first, slide all stuff down to beginning of arrays
c
          do 11 iv = 1 , nv
          do 11 kv = 1 , nvmx(iv)
            ivx = ivmx(iv,kv)
            ioff = nib(ivx,ibar-1)
            do 12 ip = 1 , nib(ivx,ibar)-ioff
              nodur(ivx,ip) = nodur(ivx,ip+ioff)
              rest(ivx,ip) = rest(ivx,ip+ioff)
12          continue
11        continue
        end if
        do 67 iv = 1 , nv
        do 67 kv = 1 , nvmx(iv)
          ioff= 0
          if(ibar.gt.1)ioff = nib(ivmx(iv,kv),ibar-1)
67      continue
        call makeabar()
        elsk(ibarcnt) = elskb+fbar
10    continue
      newmeter = .false.		
      firstline = .false.
      go to 30
20    continue
c
c Vertical analysis.
c
      if (npages .eq. 0) then
        if (nsyst .eq. 0) then
          print*,'When npages=0, must set nsyst=bars/syst, not 0'
          stop 1
        end if
        nsyst = (ibarcnt-1)/nsyst+1
        if (nv .eq. 1) then
          nsystpp = 12
        else if (nv .eq. 2) then
          nsystpp = 7
        else if (nv .eq. 3) then
          nsystpp = 5
        else if (nv .eq. 4) then
          nsystpp = 3
        else
          nsystpp = 2
        end if
        npages = (nsyst-1)/nsystpp+1
      end if
c
c  Check nsyst vs ibarcnt
c
      if (nsyst .gt. ibarcnt) then
        print*
        print*,'nsyst,ibarcnt:',nsyst,ibarcnt
        print*,'There are more systems than bars.'
        stop 1
      end if
c
c  Set up dummy forced line & page breaks after last real one
c
      nflb = nflb+1
      ibarflb(nflb) = ibarcnt+1
      isysflb(nflb) = nsyst+1
      nfpb = nfpb+1
      ipagfpb(nfpb) = npages+1
      isysfpb(nfpb) = nsyst+1
      heightil = ptheight*4./musize
      open(12,status='SCRATCH')
      write(12,'(a)')basenameq(1:lbase)
      write(12,*)lbase
c
c Pass to pmxb the initial signature, including effect of transposition.
c
      write(12,'(6f10.5/f10.5,3i5)')fbar,wheadpt,etait,
     *     etatc,etacs1,etatop,etabot,inbothd,inhnoh,isig1
      write(12,*)npages,widthpt,ptheight,nsyst
      iflbnow = -1
      isysb4 = 0
      do 8 ifpb = 1 , nfpb
c
c  Each time thru this loop is like a single score with several pages
c
        npages = ipagfpb(ifpb)-ipagfpb(ifpb-1)
        nsyst = isysfpb(ifpb)-isysfpb(ifpb-1)
        nomnsystp = (nsyst-1)/npages+1
        nshort = nomnsystp*npages-nsyst
        do 7 ipage = 1 , npages
          nsystp = nomnsystp
          if (ipage .le. nshort) nsystp = nsystp-1
c
c  Last system number on this page:
          isysendpg = isysb4+nsystp
          nintpg = 0
          do 15 isy = isysb4+1, isysendpg
            if (isysflb(iflbnow+1) .eq. isy) iflbnow = iflbnow+1
            nintpg = nintpg+nistaff(iflbnow)
15        continue
          xilfrac = 0.
          xiltxt = 0.
          if (ipage.eq.1 .and. ihead.gt.0) then
c
c  Needn't zero out ihead after printing titles if we only allow titles at top?
c
            if (iand(ihead,1) .eq. 1) then
              xiltxt = xiltxt+hgtin*4/musize
              xilfrac = xilfrac+etait
            end if
            if (iand(ihead,2) .eq. 2) then
              xiltxt = xiltxt+hgtti*4/musize
              xilfrac = xilfrac+etatc
            end if
            if (iand(ihead,4) .eq. 4) then
              xiltxt = xiltxt+hgtco*4/musize
              xilfrac = xilfrac+etacs1
            else
c
c Use double the title-composer space if there is no composer
c
              xilfrac = xilfrac+etatc
            end if
          end if
          D = xilfrac+nsystp-1+etatop+etabot
c          C = nsystp*(nv-1)
          C = nintpg
c          xN = heightil - xiltxt - 4*nsystp*nv - (nsystp-1)*xilbn
          xN = heightil - xiltxt - 4*(nintpg+nsystp) - (nsystp-1)*xilbn
          if (bottreb) xN = xN-(nsystp-1)*xilbtc
          if (ihead.eq.0 .and. isheadr) xN = xN - xilhdr
          if (ifig .eq. 1) then
            xN = xN - nsystp*xilfig
          end if
          glueil = (xN-b*C)/(D+a*C)
          omegaG = (b*D+a*xN)/(D+a*C)
c
c  G = \interlines between systems
c  omega*G = \interlines between staves of the same system
c  \interstaff = 4+omega*G
c  C = total number of interstaff spaces in the page
c  D = omega-indep factors for scalable height = nsy-1 (intersystem glue)
c      + etatop + etabot + etatxt +
c  N = scaleable height (\interlignes) = height - htext - staff heights - xil
c  xil = extra interliges = (nsy-1)*xilbn + 10 if header and no titles
c                          + (nsy-1)*xiltcb    for treble clef bottoms
c                          + nsy*xilfig        for figures
c  G = N/(D + omega * C) = glueil,   (1)
c  But (empirically)  omega*G = a*G + b (2)
c      with a=1.071 and b=2.714
c  Solving (1) and (2) gives
c      G = (N-b*C)/(D+a*C) , omega*G = (b*D+a*N)/(D+a*C)
c  Pass to pmxb    omega*G (=\interstaff-4)
c                  (etatop,bot,it,tc,cx)*G as inputs to \titles
c
c       glueil = (heightil-xiltxt-nsystp*(xil+4*nv))
c    *             /(nsystp*(1+gfact*(nv-1))-1+etatop+etabot+xilfrac)
c       xnsttop = glueil*etatop
c       xintstaff = 4+gfact*glueil
c
c  Only the first page will get local adjustment now if needed, others in pmxb
c
          if (ifpb.eq.1 .and. ipage.eq.1 .and. fintstf.gt.0.) then
            facins = fintstf
            fintstf = -1.
          else
c
c  gintstf = 1.0 by default, but may be changed with AI<x>
c
            facins = gintstf
          end if
          write(12,*)nsystp,max(0.,etatop*glueil),facins*(omegaG+4)
          ihead = 0
          isheadr = .false.
          isysb4 = isysendpg
7       continue
8     continue
c
c  Done with vertical, now do horizontals
c
      celsk(1) = elsk(1)
      do 21 ibar = 2 , ibarcnt
        celsk(ibar) = celsk(ibar-1)+elsk(ibar)
21    continue
      lastbar(0) = 0
      ibar1 = 1
      wmins = -1.
      iflb = 1
      imovbrk = 0
      ikey = 1
c
c  Return nsyst to its *total* value
c
      nsyst = isysfpb(nfpb)-1
      do 22 isyst = 1 , nsyst
        if (isyst .eq. isysflb(iflb)) iflb = iflb+1
        if (nmovbrk.gt.0 .and. imovbrk.lt.nmovbrk) then
          if (isyst .eq. isysmb(imovbrk+1)) imovbrk = imovbrk+1
        end if
        ibarb4 = lastbar(isyst-1)
        if (isyst .eq. 1) then
          if (isfirst) elsstarg = celsk(ibarflb(1)-1)/
     *            (isysflb(1)-1-fracindent)*(1-fracindent)
          celskb4 = 0.
        else
          celskb4 = celsk(ibarb4)
c
c  Must dimension isysmb(0:*) just so I can execute this test!
c
          if (isfirst) then
            if (nmovbrk.gt.0 .and. isyst.eq.isysmb(imovbrk)) then
c
c  First syst after forced line break.  There may be indentation.
c
              elsstarg = (celsk(ibarflb(iflb)-1)-celskb4)
     *          /(isysflb(iflb)-isyst-fracsys(imovbrk))
     *          *(1-fracsys(imovbrk))
            else
c
c  There is no indentation to deal with
c
              elsstarg = (celsk(ibarflb(iflb)-1)-celskb4)
     *                           /(isysflb(iflb)-isyst)
            end if
          end if
        end if
        if (isfirst) then
          diff1 = abs(elsstarg-elsk(ibarb4+1))
          do 23 ibar = ibarb4+2 , ibarcnt
            diff = elsstarg-(celsk(ibar)-celskb4)
            if (abs(diff) .ge. diff1) go to 24
            diff1 = abs(diff)
23        continue
24        ibar = ibar-1
          lastbar(isyst) = ibar
          nbarss(isyst) = ibar-ibarb4
        else
c
c  nbarss is given as an input, must compute lastbar and ibar
c
          lastbar(isyst) = nbarss(isyst)+ibarb4
          ibar = lastbar(isyst)
        end if
c
c  elss is # of elemskip in the syst. from notes & ars's, not ruleskips, ask's.
c
        elss(isyst) = celsk(ibar)-celskb4
        write(12,'(i5)')lastbar(isyst-1)+1
c
c  Transposed sigs are isig1, newkey(2,3,...).
c
        if (ikey .eq. 1) then
          key1 = isig1
        else
          key1 = newkey(ikey)
        end if
        fsyst = wclef+abs(key1)*wkeysig+2./musize
        xelsk = 0.
1       if (ikey.lt.nkeys) then
          if (ibrkch(ikey+1).le.lastbar(isyst)) then
c
c  Add space for all key changes
c
            ikey = ikey+1
            key2 = newkey(ikey)
            nacc = max(abs(key2-key1),max(abs(key1),abs(key2)))
            fsyst = fsyst+nacc*wkeysig
c
c  Account for afterruleskips (fbar)
c
            xelsk = xelsk+fbar/2
            if (ibrkch(ikey).lt.lastbar(isyst) .and. .not.kchmid(ikey))
     *          xelsk = xelsk-1.
            key1 = key2
            go to 1
          end if
        end if
c
c  Add extra fixed space for double bar
c
        if (isyst .eq. nsyst) then
          fsyst = fsyst+4.5/musize
        end if
c
c  Add extra fixed space for initial time signature
c
        if (isyst .eq. 1) then
          fsyst = fsyst+wtimesig
        end if
c
c  Add extra fixed space for time signature changes & user-defined spaces
c
        do 26 ibars = ibarb4+1 , lastbar(isyst)
          if (newmb(ibars)) fsyst = fsyst+wtimesig
          fsyst = fsyst+udsp(ibars)/musize
26      continue
        if (isyst .eq. 1) then
          wdpt = widthpt*(1-fracindent)
        else
          if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and.
     *                isyst.eq.isysmb(imovbrk)) then
            wdpt = widthpt*(1-fracsys(imovbrk))
          else
            wdpt = widthpt
          end if
        end if
        wsyspt = wdpt-fsyst*musize-0.4*nbarss(isyst)
c
c  Checks for min spacing
c  Get min allowable space
c
        dtmin = 1000.
        do 45 ibar = ibar1 , ibar1+nbarss(isyst)-1
          dtmin = min(dtmin,tnminb(ibar))
          if (wminnh(ibar).ge.0.) wmins = wminnh(ibar)
45      continue
        if (wmins .lt. 0) wmins = 0.3
        wminpt = (1+wmins)*0.3*musize
c
c  Find max duration & # of notes for this system
c
        dtmax = 0.
        nns = 0
        do 43 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1
          dtmax = max(dtmax,durb(iptr))
          nns = nns + nnpd(iptr)
43      continue
        elmin0 = wsyspt*f1eon(dtmin)/(elss(isyst)+xelsk)
        if (elmin0 .ge. wminpt) then
c
c  Subtract out fbar stuff to keep old way of passing sumelsk to pmxb;
c    there is no need to "flatten"
c
          sumelsk = elss(isyst)-fbar*nbarss(isyst)
          eonk = 0.
          ewmxk = 1.
        else
          elmin1 = wsyspt/((fbar*nbarss(isyst)+xelsk)/f1eon(dtmax)+nns)
          if (elmin1 .le. wminpt) then
            print*
            print*,'In system #',isyst,' cannot meet min. space rqmt'
            write(15,'(/a,i5,a)')
     *         'In system #',isyst,' cannot meet min. space rqmt'
            eonk = 0.9
          else
c
c  Find eonk by Newton method
c
c            eonk = min(.9,(wminpt-elmin0)/(elmin1-elmin0))
            call findeonk(nptr(ibar1),nptr(ibar1+nbarss(isyst))-1,
     *         wsyspt/wminpt,fbar*nbarss(isyst)+xelsk,dtmin,dtmax,
     *         (wminpt-elmin0)/(elmin1-elmin0))
            eonk = min(.9,eonk)
          end if
          ewmxk = f1eon(dtmax)**eonk
c
c  Recompute poenom!
c
          sumelsk = 0
          do 44 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1
            sumelsk = sumelsk
     *       + nnpd(iptr)*sqzb(iptr)*feon(durb(iptr)/sqzb(iptr))
44        continue
        end if
        poenom = wsyspt/(sumelsk+fbar*nbarss(isyst)+xelsk)
c
c Set fracindent for output: orig if isyst=1, fracsys(imovbrk) if movbrk, else 0
c
        if (isyst .gt. 0) then
          if (nmovbrk.gt.0 .and. imovbrk.gt.0 .and.
     *        isyst.eq.isysmb(imovbrk)) then
            fracindent = fracsys(imovbrk)
          else
            fracindent = 0.
          end if
        end if
        write(12,'(1pe12.5/i5,5e12.3)') poenom,nbarss(isyst),
     *       sumelsk,fsyst,fracindent,eonk,ewmxk
        ibar1 = ibar1+nbarss(isyst)
22    continue
      rewind(12)
      open(13,status='SCRATCH')
      write(13,'(i5)')ifig
      rewind(13)
      ilbuf = 1
      ipbuf = 0
      if (.not.optimize) then
        write(*,'(/,a)')' Done with first pass'
        print*
        write(15,'(/,a)')' Done with first pass'
        write(15,'()')
      end if
c
c  Following syntax is needed since pmxa is called with literal argument .false.
c
      if (isfirst) isfirst = .false.
      return
      end
      subroutine g1etnote(loop,ifig,optimize)
      parameter (nm=12,nkb=600,mv=24576)
      character*1 chax
      common /a1ll/ iv,ivxo(200),ipo(200),to(200),tno(200),nnl(nm),
     *   nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
     *   nbars,itsofar(nm),nib(nm,15),nn(nm),
     *   rest(nm,200),lenbr0,lenbr1,firstline,newmeter
      common /c1omnotes/ nnodur,wminnh(nkb),nnpd(2000),durb(2000),iddot,
     *     nptr(nkb),ibarcnt,mbrest,ibarmbr,
     *     ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(2000)
      common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
     *     fracindent,nsperi(nm)
      common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40),
     *      isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
     *      usefig,fintstf,gintstf,fracsys(20),nmovbrk,isysmb(0:20),
     *      nistaff(0:40)
      common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar
      common /comkeys/ nkeys,ibrkch(18),newkey(18),iskchb,idsig,isig1,
     *       kchmid(18),ornrpt,shifton,barend,noinst
      logical lastchar,firstline,rest,loop,newmeter,fbon,issegno,barend,
     *        isheadr,fulbrp,usefig,isvolt,iskchb,kchmid,plusmin,ornrpt
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      common /commus/ musize,whead20
      logical mrecord,mplay,endmac,shifton,gotclef,
     *        optimize
      character*128 lineq,lnholdq
      character*1 charq,dotq,dumq,durq,charlq
      character*51 literq(2)
      data literq
     *   /'Literal TeX string cannot start with 4 backslashes!',
     *    'TeX string must have <129 char, end with backslash!'/
      integer*2 mmidi
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
1     call g1etchar(lineq,iccount,charq)
      if (charq .ne. ' ') charlq = charq
      if (lastchar) then
        if (index('/%',charlq) .eq. 0) then
          print*,'Last non-blank character is "',charlq,'", not "/,%"'
          print*,'ASCII code:',ichar(charlq)
          stop 1
        end if
        return
      end if
      if (charq .eq. ' ') then
        go to 1
      else if (charq.eq.'%' .and. iccount.eq.1) then
        iccount = 128
        go to 1
      else if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or.
     *       charq.eq.'r') then
c
c  This is a note/rest. gotclef is only used for checking for clef before "/"
c
        if (gotclef) gotclef=.false.
        idotform = 0
        numnum = 0
        plusmin = .false.
28      nnl(ivx) = nnl(ivx)+1
        if (nnl(ivx) .gt. 200) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      '>200 notes in line of music. Use smaller blocks!')
          stop 1
        end if
        dotq = 'x'
c
c  Check if this is 'r ' and previous note was full-bar-pause
c
        fulbrp = charq.eq.'r' .and. lineq(iccount+1:iccount+1) .eq.' '
     *    .and. nnl(ivx).gt.1 .and. rest(ivx,max(1,nnl(ivx)-1)) .and.
     *    nodur(ivx,max(1,nnl(ivx)-1)) .eq. lenbar
2       call g1etchar(lineq,iccount,durq)
        ic = ichar(durq)
        if (ic.le.57 .and. ic.ge.48) then
c
c  Digit
c
          if (numnum .eq. 0) then
            nnodur = ic-48
            numnum = 1
            go to 2
          else if (numnum .eq. 1) then
            if (charq .eq. 'r') then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Only one digit allowed after rest symbol "r"!')
              stop 1
            end if
            numnum = 2
            if (plusmin) then
              print*
              print*,'*********WARNING*********'
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Before version 1.2, +/- was ignored if octave was!')
              print*,
     *           'explicitly specified.  May need to edit old editions'
            end if
            go to 2
          else
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             '>2 digits in note symbol!')
            stop 1
          end if
        else if (durq.eq.'d') then
          dotq = durq
          if (lineq(iccount+1:iccount+1) .eq. 'd') then
            iddot = 1
            iccount = iccount+1
c
c  Since we flow out, double dots won't work with other dot options
c
          end if
          if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
c
c  move a dot, provided a number follows.
c
            call g1etchar(lineq,iccount,durq)
            call g1etchar(lineq,iccount,durq)
            if (index('0123456789-.',durq) .eq. 0) then
c
c  Backup, exit the loop normally
c
              iccount = iccount-2
              go to 2
            end if
            call readnum(lineq,iccount,dumq,fnum)
            if (index('+-',dumq) .gt. 0) then
c
c  Vertical shift also
c
              call g1etchar(lineq,iccount,durq)
              if (index('0123456789-.',durq) .eq. 0) then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               'Expected number after 2nd +/- (shift dot)!')
                stop 1
              end if
              call readnum(lineq,iccount,durq,fnum)
            end if
            iccount = iccount-1
          end if
          go to 2
        else if (index('<>',durq) .gt. 0) then
c
c  Accidental shift
c
          if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then
            call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *         'Expected "f", "s", or "n" before "<" or ">"!')
            stop 1
          end if
          call g1etchar(lineq,iccount,durq)
          if (index('123456789.0',durq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'Expected number after </> (accidental shift)!')
            stop 1
          end if
          call readnum(lineq,iccount,durq,fnum)
          if (fnum .gt. 3.15) then
            call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *       'Horizontal accidental shift must be less than 3.15!')
            stop 1
          end if
          iccount = iccount-1
          go to 2
        else if (index('+-',durq) .gt. 0) then
          if (charq .ne. 'r') then
            if (index('fsn',lineq(iccount-1:iccount-1)) .gt. 0 .and.
     *        index('0123456789',lineq(iccount+1:iccount+1)).gt.0) then
c
c  This may be start of accidental shift, but may be octave and duration
c
              icsav = iccount
              iccount = iccount+1
              call readnum(lineq,iccount,durq,fnum)
              if (index('+-',durq) .gt. 0) then
c
c  This is an accid shift
c
                if (fnum .gt. 30.5) then
                  call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *           'Vertical accidental shift must be less than 31!')
                  stop 1
                end if
                call g1etchar(lineq,iccount,durq)
                if (index('1234567890.',durq) .eq. 0) then
                  call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Expected 2nd number of 2-number accidental shift)!')
                  stop 1
                end if
                call readnum(lineq,iccount,durq,fnum)
                if (fnum .gt. 3.15) then
                  call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *           'Horizontal accidental shift must be less than 3.15!')
                  stop 1
                end if
                iccount = iccount-1
                go to 2
              else
c
c  Not accid shift, reset, then flow out
c
                iccount = icsav
              end if
            end if
            plusmin = .true.
            if (numnum .eq. 2) then
              print*
              print*,'*********WARNING*********'
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Before version 1.2, +/- was ignored if octave was!')
              print*,
     *           'explicitly specified.  May need to edit old editions'
            end if
            go to 2
c
c  It's a rest containing +|- .  Must refer to a vertical shift.  Read past.
c
          else
            call g1etchar(lineq,iccount,durq)
            call readnum(lineq,iccount,durq,dum)
            iccount = iccount-1
            go to 2
          end if
        else if (index('fsnulare',durq) .gt. 0) then
          go to 2
        else if (durq .eq. 'p') then
          fulbrp = charq.eq.'r'
          if (.not. fulbrp) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'The option "p" only works with "r" (rest)!')
            stop 1
          end if
          go to 2
        else if (durq .eq. 'b') then
          if (charq .ne. 'r') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'You entered "b"; I expected "rb"!')
            stop 1
          else if (numnum .eq. 2) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'You entered "r" & "b" with two numbers!')
          end if
          go to 2
        else if (durq .eq. 'x') then
c
c  xtuplet: Set all durations to 0 except last one.
c
          call g1etchar(lineq,iccount,durq)
          if (index('123456789',durq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'First char after "x" in xtuplet must be "1"-"9"!')
            stop 1
          end if
          call readnum(lineq,iccount,durq,fnum)
          if (fnum .gt. 99) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Xtuplet cannot have more than 99 notes!')
            stop 1
          else if (index(' n',durq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Only legal characters here are " " or "n"!')
            stop 1
          end if
          if (durq .eq. 'n') then
c
c  Number alteration stuff
c
            numshft = 0
30          call g1etchar(lineq,iccount,durq)
            if (durq .eq. 'f') then
              go to 30
            else if (index('+-',durq) .gt. 0) then
              numshft = numshft+1
              if (numshft .eq. 3) then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Only 2 numbers are allowed after "n" in xtup!')
                stop 1
              end if
              call g1etchar(lineq,iccount,durq)
              if (index('0123456789.',durq) .eq. 0) then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'This character should be a digit or "."!')
                stop 1
              end if
              call readnum(lineq,iccount,durq,snum)
              iccount = iccount-1
              if ((numshft.eq.1 .and. snum.gt.15.1) .or.
     *             (numshft.eq.2 .and. snum.gt.1.51)) then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *              'Number after "n" in xtup is out of range!')
                stop 1
              end if
              go to 30
            else if (durq .ne. ' ') then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Illegal character after "n" in xtup!')
              stop 1
            end if
          end if
          ntup = nint(fnum)
          do 6 itup = 2 , ntup
            nodur(ivx,nnl(ivx)) = 0
            nnl(ivx) = nnl(ivx)+1
110         call g1etchar(lineq,iccount,durq)
            if (durq.eq.' ') then
              go to 110
            else if (durq .eq. 'o') then
c
c  Ornament in xtup.  "o" symbol must come AFTER the affected note
c
              call g1etchar(lineq,iccount,dumq)
              if (index('(stmx+Tup._)e:>^',dumq) .eq. 0 ) then
                if (index('fg',dumq) .gt. 0) then
                  call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               'Fermata or segno not allowed in xtuplet!')
                else
                  call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *                 'Illegal ornament!')
                end if
                stop 1
              end if
              if (dumq .eq. 'T') then
c
c  Trill.  may be followed by 't' and/or number.  read 'til blank
c
29              call g1etchar(lineq,iccount,dumq)
                if (dumq .ne. ' ') go to 29
              else if (dumq .eq. 'e') then
                call g1etchar(lineq,iccount,dumq)
                if (index('sfn?',dumq) .eq. 0) then
                  call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *            'Illegal character after "e" in edit. accid. symbol!')
                  stop 1
                end if
                call g1etchar(lineq,iccount,dumq)
                if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq)
              else if (dumq .eq. ':') then
                if (lineq(iccount+1:iccount+1) .ne. ' ') then
                  call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *            '":" must be followed by blank in "o: "!')
                  stop 1
                else if (.not.ornrpt) then
                  call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *            'Turned off repeated ornaments before they were on!')
                  stop 1
                end if
                ornrpt = .false.
              else
                call g1etchar(lineq,iccount,dumq)
              end if
              if (index('+- :',dumq) .eq. 0) then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *            'Illegal character in ornament symbol!')
                stop 1
              end if
              if (dumq .eq. ':') then
                if (lineq(iccount+1:iccount+1) .ne. ' ') then
                  call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *            '":" must be followed by blank in "o: "!')
                  stop 1
                else if (ornrpt) then
                  call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               'Turned on repeated ornaments but already on!')
                  stop 1
                end if
                ornrpt = .true.
              end if
c              if (index('+-',dumq) .gt. 0) 
c     *               call readnum(lineq,iccount,durq,fnum)
              if (index('+-',dumq) .gt. 0) then
                call readnum(lineq,iccount,durq,fnum)
                if (durq .eq. ':') then
                  call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               'Cannot shift AND repeat an ornament!')
                  stop 1
                end if
              end if
              go to 110
            else if (index('st()',durq) .gt. 0) then
              iposn = 0
              numint = 0
15            call g1etchar(lineq,iccount,dumq)
              iposn = iposn+1
              if (index('udltb',dumq) .gt. 0) then
                go to 15
              else if (index('+-',dumq) .gt. 0) then
                numint = numint+1
                iccount = iccount+1
                call readnum(lineq,iccount,durq,fnum)
                if (numint .eq. 1) then
                  if (nint(fnum) .gt. 15) then
                    call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *       'Magnitude of slur height adjustment cannot exceed 15!')
                    stop 1
                  end if
                else if (numint .eq. 2) then
                  if (abs(fnum).gt.6.3) then
                    call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *              'Slur horiz shift must be in the range (-6.3,6.3)!')
                    stop 1
                  end if
                else
c
c  Third signed integer, must be a midslur or curve spec.
c
                  if (abs(fnum).gt.31) then
                    call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *                  'Slur midheight must be in the range (-31,31)!')
                    stop 1
                  end if
                  if (durq .eq. ':') then
c
c  Expecting curve parameters.  Get two numbers
c
                    do 40 i = 1 , 2
                      iccount = iccount+1
                      fnum = ichar(lineq(iccount:iccount))-48
                      if (abs(fnum-3.5) .gt. 3.6) then
                        call errmsg(lineq,iccount,
     *                      ibarcnt-ibaroff+nbars+1,
     *           'Slur curve parameter must be in range (0,7)!')
                        stop 1
                      end if
40                  continue
                    iccount = iccount+1
                  end if
                end if
                iccount = iccount-1
                go to 15
              else if (dumq .ne. ' ') then
                ic = ichar(dumq)
                if ((ic.ge.48.and.ic.le.57) .or.
     *                    (ic.ge.65.and.ic.le.90)) then
                  if (iposn .eq. 1) go to 15
                  call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *              'Slur ID must be 2nd character in slur symbol!')
                  stop 1
                end if
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *                   'Illegal character in slur symbol!')
                stop 1
              end if
              go to 110
            else if (index('0123456789#-nx_',durq) .gt. 0) then
c
c  We have a figure.  Only allow on 1st note of xtup
c
              if (itup .ne. 2) then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Figure in xtup only allowed on 1st note!')
                stop 1
              else if (durq.eq.'x') then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *            'No floating figures in xtuplets!')
                stop 1
              end if
              if (usefig .and. ivx.eq.1) ifig = 1
26            call g1etchar(lineq,iccount,durq)
              if (index('0123456789#-n_',durq) .gt. 0) then
                go to 26
              else if (durq .ne. ' ') then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *            'Illegal character in figure in xtuplet!')
                stop 1
              end if
              go to 110
            else if (durq .eq. chax(92)) then
              call chklit(lineq,iccount,literr)
              if (literr .gt. 0) then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               literq(literr))
                stop 1
              end if
              go to 110
            else if (durq .eq. 'M') then
c
c  Temporary trap until I get around putting this in pmxb
c
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'Macros not yet allowed in xtuplets!')
              stop 1
            else if (durq .eq. 'X') then
              call g1etx(lineq,iccount,.false.,shifton,
     *            ibarcnt-ibaroff+nbars+1,udsp(ibarcnt+nbars+1),wheadpt)
              go to 110
            else if (durq .eq. 'z') then
c
c  Chord note in xtup.  Read past for now.
c
33            call g1etchar(lineq,iccount,durq)
              if (durq .ne. ' ') go to 33
              go to 110
            end if
            if (index('abcdefgr',durq) .eq. 0) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'In xtup, this character is not allowed!')
              stop 1
            else if (durq.eq.'r' .and. itup.eq.ntup) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'Sorry, PMX cannot end an xtuplet with a rest!')
              stop 1
            end if
7           call g1etchar(lineq,iccount,durq)
            if (index('sfn2345678ul',durq) .gt. 0) then
              go to 7
		  else if (index('+-<>',durq) .gt. 0) then
c
c  May have either octave jump or shifted accid. on main xtup note
c
              if (index('+-',durq).gt.0 .and.
     *          index('01234567890',lineq(iccount+1:iccount+1)).eq.0)
     *          go to 7
              iccount = iccount+1
              call readnum(lineq,iccount,durq,fnum)
              iccount = iccount-1
              go to 7
            else if (durq .ne. ' ') then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'Illegal option on xtuplet note!')
              stop 1
            end if
6         continue
c
c  6==End of loop for xtuplet input
c
        else if (durq .eq. 'm') then
c
c  Multi-bar rest: next 1 or two digits are # of bars.
c
          if (iv .gt. 1) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Cannot have multibar rest if nv>1!')
            stop 1
          else if (mod(itsofar(iv),lenbar) .ne. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Multibar rest must start at beginning of bar!')
            stop 1
          else if (ibarmbr .gt. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Only one multibar rest allowed per block!')
            stop 1
          end if
c
c  For some purposes, pretend its one bar only
c
          nodur(iv,nnl(iv)) = lenbar
          ibarmbr = nbars+1
          mbrest = 0
20        call g1etchar(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
          if (durq .ne. ' ') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Illegal character after "rm"!')
            stop 1
          end if
        else if (durq .eq. '.') then
c
c  Dotted pattern.  Close out note.  Mult time by 3/4.
c  Set time for next note to 1/4.  Start the note.
c
          idotform = 1
        else if (durq .eq. ',') then
          idotform = 3
c
c  Now flow to duration setting, as if durq=' '
c
        else if (durq .eq. 'o') then
c
c  Suppress full bar rest
c
          if (charq .ne. 'r') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           '"o" option only legal for rest, not note!')
            stop 1
          end if
          go to 2
        else if (durq .ne. ' ') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Illegal character!')
          print*,'ASCII code:',ichar(durq)
          stop 1
        end if
c
c  Set the duration
c
        if (idotform .gt. 0) then
          if (idotform .eq. 1) then
            nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)*3/2
          else if (idotform .eq. 2) then
            nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3
          else if (idotform .eq. 3) then
            nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)
          else if (idotform .eq. 4) then
            nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2
          end if
        else if (ibarmbr.ne.nbars+1 .and. .not.fulbrp) then
          nodur(ivx,nnl(ivx)) = i1fnodur(nnodur,dotq)
c
c  Check for double dot
c
          if (iddot .eq. 1) then
            nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6
            iddot = 0
          end if
        else if (fulbrp) then
          nodur(ivx,nnl(ivx)) = lenbar
c
c  Use a one-line function to set nnodur.  It gives inverse of ifnodur.
c
          nnodur = index('62514x0x37',
     *                   chax(48+int(log(.1+lenbar)/.69315)))-1
          fulbrp = .false.
        end if
        rest(ivx,nnl(ivx)) = charq.eq.'r'
c
c  If inside forced beam, check if note is beamable
c
        if (fbon) then
          if (nodur(ivx,nnl(ivx)) .lt. 16) go to 120
          if (nnl(ivx) .gt. 1) then
            if (nodur(ivx,nnl(ivx)-1) .eq. 0) go to 120
          end if
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Unbeamable thing in forced beam!')
          stop 1
        end if
120     continue
        itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
        if (mod(itsofar(ivx),lenbar) .eq. 0) then
          nbars = nbars+1
          if (shifton) barend = .true.
c
c  Will check barend when 1st note of next bar is entered.
c
          if (nbars .gt. 15) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'Cannot have more than 15 bars in an input block!')
            stop 1
          end if
          nib(ivx,nbars) = nnl(ivx)
          if (firstline .and. lenbar.ne.lenbr1) then
c
c  Just finished the pickup bar for this voice.
c
            if (itsofar(ivx) .ne. lenbr0) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               'Pickup bar length disagrees with mtrnum0!')
              stop 1
            end if
            lenbar = lenbr1
            itsofar(ivx) = 0
          end if
        else if (barend) then
          if (shifton) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'Bar ended with user-defined shift still on!')
            stop 1
          end if
          barend = .false.
        end if
        if (idotform.eq.1 .or. idotform.eq.3) then
          call g1etchar(lineq,iccount,charq)
          if (index('abcedfgr',charq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *        'Expected note name or "r" here!')
            stop 1
          end if
          idotform = idotform+1
          numnum = 1
          go to 28
        end if
c
c  End of sub block for note-rest
c
      else if (charq .eq. 'z') then
        call g1etchar(lineq,iccount,charq)
25      call g1etchar(lineq,iccount,durq)
        if (index('nfsdre12345678',durq) .gt. 0) then
          go to 25
        else if (index('<>',durq) .gt. 0) then
          if (index('fsn',lineq(iccount-1:iccount-1)) .eq. 0) then
            call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *        'Must have "f,s,n" before "<" or ">"!')
            stop 1
          end if
          call g1etchar(lineq,iccount,durq)
          if (index('1234567890.',durq) .eq. 0) then
            call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *        'Expected a number to start here for accidental shift!')
            stop 1
          end if
          call readnum(lineq,iccount,durq,fnum)
          iccount = iccount-1
          go to 25
        else if (index('+-',durq) .gt. 0) then
          if (index('1234567890.',lineq(iccount+1:iccount+1)) .eq. 0)
     *         go to 25
c
c  Number or '.' (durq) follows +/- .   Get it.
c
          call g1etchar(lineq,iccount,durq)
          if (durq .eq. '.' .and. index('1234567890',
     *                  lineq(iccount+1:iccount+1)) .eq. 0) then
            call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *        '"." here must be followed by a digit!')
            stop 1
          else if (index('sfnd',lineq(iccount-2:iccount-2)) .eq. 0) then
            call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *        'Number after +/- must follow "d,s,f,n"!')
            stop 1
          end if
          call readnum(lineq,iccount,durq,fnum)
          if (index('+-',durq) .eq. 0) then
            iccount = iccount-1
            go to 25
          end if
c
c  2nd +/-
c
          call g1etchar(lineq,iccount,durq)
          if (durq .eq. '.') call g1etchar(lineq,iccount,durq)
          if (index('1234567890',durq) .eq. 0) then
            call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *        'Expected a number here!')
            stop 1
          end if
          call readnum(lineq,iccount,durq,fnum)
          iccount = iccount-1
          go to 25
        else if (durq .ne. ' ' .or. index('abcdefg',charq).eq.0) then
          call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *      'Illegal character in chord note!')
          stop 1
        end if
      else if (charq .eq. 'G') then
        ngr = 1
9       call g1etchar(lineq,iccount,charq)
        if (index('123456789',charq) .gt. 0) then
          call readnum(lineq,iccount,durq,fnum)
          ngr = nint(fnum)
          iccount = iccount-1
          go to 9
        else if (index('AWulxs',charq) .gt. 0) then
          go to 9
        else if (charq .eq. 'm') then
          call g1etchar(lineq,iccount,charq)
          if (index('01234',charq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'A digit less than 5 must follow "m" in a grace note!')
            stop 1
          end if
          go to 9
        end if
c
c  At this point, charq is first note name in rest (grace?)
c
        do 19 igr = 1 , ngr
          numnum = 0
          if (igr .gt. 1) then
55          call g1etchar(lineq,iccount,charq)
            if (charq .eq. ' ') go to 55
          end if
          if (index('abcdefg',charq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'In grace, expected "a"-"g"!')
            stop 1
          end if
18        call g1etchar(lineq,iccount,charq)
          if (charq .ne. ' ') then
            if (index('+-1234567',charq) .gt. 0) then
              if (numnum .eq. 1) then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *            'Only one of "+-1234567" allowed here in grace!')
                stop 1
              end if
              numnum = 1
              go to 18
            else if (index('nfs',charq) .gt. 0) then
              go to 18
            end if
c
c  Digits are possible octave numbers
c
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'Illegal character after note name in grace!')
            stop 1
          end if
19      continue
      else if (charq .eq. chax(92)) then
        call chklit(lineq,iccount,literr)
        if (literr .gt. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               literq(literr))
          stop 1
        end if
      else if (charq .eq. 'o') then
c
c  "o" symbol must come AFTER the affected note
c
        if (nnl(ivx) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *     '"o" must be in same input block, after affected note!')
          stop 1
        end if
        call g1etchar(lineq,iccount,dumq)
        if (index('(stmgx+Tupf._)e:>^',dumq) .eq. 0 ) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Illegal ornament!')
          stop 1
        end if
        if (dumq .eq. ':') then
          call g1etchar(lineq,iccount,dumq)
          if (dumq .ne. ' ') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'Expected blank after "o:"!')
            stop 1
          else if (.not.ornrpt) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *            'Turned off repeated ornaments before they were on!')
            stop 1
          end if
          ornrpt = .false.
        else if (dumq .eq. 'g') then
          if (issegno) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Sorry, only one "segno" per input block!')
            stop 1
          else if (ivx .ne. 1) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'segno can only be in voice 1!')
            stop 1
          end if
          issegno = .true.
12        call g1etchar(lineq,iccount,dumq)
          if (dumq.eq.'-' .or.
     *        (ichar(dumq).ge.48.and.ichar(dumq).le.58)) go to 12
          if (dumq .ne. ' ') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Illegal character in segno ornament symbol!')
            stop 1
          end if
        else if (dumq .eq. 'T') then
c
c  Trill.  may be followed by 't' and/or number.  read 'til blank
c
22        call g1etchar(lineq,iccount,dumq)
          if (dumq .eq. ':') then
            if (lineq(iccount+1:iccount+1) .ne. ' ') then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'Expected blank after ":"!')
              stop 1
            end if
            go to 32
          else if (dumq .ne. ' ') then
            go to 22
          end if
        else if (dumq .eq. 'f') then
          call g1etchar(lineq,iccount,dumq)
          if (index(' d+-:',dumq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'Illegal character after "f" in fermata ornament symbol!')
            stop 1
          end if
          if (dumq .eq. 'd') call g1etchar(lineq,iccount,dumq)
          if (dumq .eq. ':') go to 32
        else if (dumq .eq. 'e') then
          call g1etchar(lineq,iccount,dumq)
          if (index('sfn?',dumq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'Illegal character after "e" in edit. accid. symbol!')
            stop 1
          end if
          call g1etchar(lineq,iccount,dumq)
          if (dumq .eq. '?') call g1etchar(lineq,iccount,dumq)
        else
          call g1etchar(lineq,iccount,dumq)
        end if
        if (index('+- :',dumq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'Illegal character in ornament symbol!')
          stop 1
        end if
        if (index('+-',dumq) .gt. 0) then
          call readnum(lineq,iccount,durq,fnum)
          if (durq .eq. ':') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *        'Cannot shift AND repeat an ornament!')
            stop 1
          end if
        end if
32      continue
        if (dumq .eq. ':') then
          if (lineq(iccount+1:iccount+1) .ne. ' ') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      '":" must be followed by blank in "o: "!')
            stop 1
          else if (ornrpt) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               'Turned on repeated ornaments but already on!')
            stop 1
          end if
          ornrpt = .true.
        end if
      else if (index('st()',charq) .gt. 0) then
        numint = 0
        iposn = 0
8       call g1etchar(lineq,iccount,dumq)
        iposn = iposn+1
        if (index('udltb+- ',dumq) .eq. 0) then
c
c  Check for explicit ID code.
c
          ic = ichar(dumq)
          if (ic.lt.48 .or. (ic.gt.57.and.ic.lt.65) .or.
     *              ic.gt.90) then
c
c  Not 0-9 or A-Z, so exit
c
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *                   'Illegal character in slur symbol!')
            stop 1
          else
c
c  It is a possible ID code.  Right place?
c
            if (iposn .ne. 1) then
c
c  Slur ID is not 2nd!
c
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *            'Slur ID must be second character in slur symbol!')
              stop 1
            end if
          end if
c
c  Slur ID is OK.
c
          go to 8
        end if
        if (index('udltb',dumq) .gt. 0) then
          go to 8
        else if (index('+-',dumq) .gt. 0) then
          numint = numint+1
          if (charq .eq. 't') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *     '"+|-" for slur height only allowed in "s"-slurs!')
            stop 1
          end if
          iccount = iccount+1
          call readnum(lineq,iccount,durq,fnum)
          if (numint .eq. 1) then
            if (nint(fnum) .gt. 15) then
              call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *       'Magnitude of slur height adjustment cannot exceed 15!')
              stop 1
            end if
          else if (numint .eq. 2) then
            if (abs(fnum) .gt. 6.3) then
              call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *       'Slur horiz shift must be in range (-6.3,6.3)!')
              stop 1
            end if
          else
c
c  Third signed integer, must be a midslur or curve spec.
c
            if (abs(fnum).gt.31) then
              call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *                  'Slur midheight must be in the range (-31,31)!')
              stop 1
            end if
            if (durq .eq. ':') then
c
c  Expecting curve parameters.  Get two numbers
c
              do 41 i = 1 , 2
                iccount = iccount+1
                fnum = ichar(lineq(iccount:iccount))-48
                if (abs(fnum-3.5) .gt. 3.6) then
                  call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *                 'Slur curve parameter must be in range (0,7)!')
                  stop 1
                end if
41            continue
              iccount = iccount+1
            end if
          end if
          iccount = iccount-1
          go to 8
        end if
      else if (charq .eq. '?') then
        continue
      else if ((ichar(charq).ge.48.and.ichar(charq).le.57) .or.
     *    index('#-nx_',charq) .gt. 0) then
c
c  We have a figure.  Must come AFTER the note it goes under
c
        if (itsofar(ivx).eq.0 .and.
     *    (.not.firstline.or.lenbr0.eq.0.or.lenbar.eq.lenbr0)) then
c
c  Figure before first note in block
c
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'Cannot put figure before first note in block!')
          stop 1
        end if
        if (charq.eq.'x') then
          indxb = index(lineq(iccount:128),' ')
          if (indxb .lt. 5) then
            call errmsg(lineq,iccount+indxb-1,ibarcnt-ibaroff+nbars+1,
     *           'Cannot have a blank here in floating figure!')
            stop 1
          end if
        end if
        if (usefig) ifig = 1
5       call g1etchar(lineq,iccount,charq)
        if (charq .ne. ' ') go to 5
      else if (charq .eq. '[') then
        if (fbon) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Started forced beam while another was open!')
          stop 1
        end if
        fbon = .true.
17      call g1etchar(lineq,iccount,charq)
        if (index('uljh',charq) .gt. 0) then
          go to 17
        else if (index('+-',charq) .gt. 0) then
          iccount = iccount+1
          call readnum(lineq,iccount,durq,fnum)
          iccount = iccount-1
          go to 17
        else if (charq .eq. 'm') then
c
c  Forced multiplicity, next char should be 1-4
c
          call g1etchar(lineq,iccount,charq)
          if (index('1234',charq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *        'Forced multiplicity for a beam must be 1, 2, 3, or 4!')
            stop 1
          end if
          go to 17
        else if (charq .ne. ' ') then
          if (index('0123456789',charq) .gt. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'After "[", digits must now be preceeded by "+" or "-"!')
        print*,'You will have to edit older sources to meet this rqmt,'
        print*,'but it was needed to allow 2-digit height adjustments.'
        print*,'Sorry for the inconvenience.  --The Management'
          else
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Illegal character after [!')
          end if
        stop 1
        end if
      else if (charq .eq. ']') then
        call g1etchar(lineq,iccount,charq)
        if (index('j ',charq) .gt. 0) then
          if (fbon) then
            fbon = .false.
          else
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Forced beam stop with no corresponding start!')
            stop 1
          end if
        else if (charq .eq. '[') then
          if (.not.fbon) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           '"][" can only go in forced beam!')
            stop 1
          end if
        else if (charq .ne. 'j') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         '"]" must be followed by blank, "j", or "["!')
          stop 1
        end if
      else if (charq .eq. 'D') then
c
c  Dynamic mark
c
        call checkdyn(lineq,iccount,ibarcnt-ibaroff+nbars+1)
      else if (index('lhw',charq) .gt. 0) then
c
c  Save position for later check
c
        icclhw = iccount
        call g1etchar(lineq,iccount,durq)
        if (index('0123456789.+- ',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'Illegal character after "l", "w", or "h"!')
          stop 1
        end if
        isheadr = isheadr .or. charq .eq. 'h'
        if (index(' +-',durq) .gt. 0) then
c
c  There is a header (or lower string?)
c
          if (index('+-',durq) .gt. 0) then
c
c  User-defined vert offset (\internote).
c
            if (charq .ne. 'h') then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               '"+" or "-" not permitted here!')
              stop 1
            end if
c
c  Have "h" followed by +/- .  Check for digit.
c     Can blow durq since not using fnum for now, but...
c
            call g1etchar(lineq,iccount,durq)
            if (index('123456789',durq) .eq. 0) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'There must be a digit here!')
              stop 1
            end if
c
c  Have "h" followed by +/- followed by a digit.  No need to get the number.
c
c           call readnum(lineq,iccount,durq,fnum)
          end if
          if (charq .ne. 'w') then
c
c  Header or lower string.
c
            if (icclhw .ne. 1) then
              call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *               '"h" or "l" must be first character in line!')
              stop 1
            end if
c
c  Read past the next line, which has the string.
c
            call read10(charq,lastchar)
            nline = nline+1
            iccount = 128
          else
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Symbol "w" (width) must be followed by a digit!')
            stop 1
          end if
        else
c
c  Height or width change spec.  Check if at start of piece.
c
          if (ibarcnt .gt. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Symbol must go at top of first input block!')
            stop 1
          end if
          call readnum(lineq,iccount,durq,dimen)
c
c  Check units.  Convert to points
c
          if (durq .eq. ' ' .or. durq .eq. 'p') then
            dimen = dimen+.5
          else if (durq .eq. 'i') then
            dimen = dimen*72+.5
          else if (durq .eq. 'm') then
            dimen = dimen/25.4*72+.5
          else
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'Illegal unit; must be "p","i",or"m"!')
            stop 1
          end if
          if (charq .eq. 'h') then
            ptheight = int(dimen)
          else
            widthpt = int(dimen)
          end if
        end if
      else if (charq .eq. 'm') then
c
c  Time signature change.  Only allow at beginning of block.
c    mtrnuml, mtrdenl (logical) and p (printable) will be input.
c    mtrnuml=0 initially. (In common)
c
c  Check whether at beginning of a block
c
        if (ivx.ne.1 .or. nnl(1).ne.0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *     'Meter change only OK in voice 1, at start of block!')
          print*,'voice number is',ivx
          stop 1
        end if
        newmeter = .true.
        call readmeter(lineq,iccount,mtrnuml,mtrdenl)
        if (mtrnuml .eq. 0) then
          call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *     'Digit 0 not allowed here!')
          stop 1
c        else if (mtrdenl .eq. 1) then
cc
cc  Kluge!!!
cc
c          mtrdenl = 2
c          mtrnuml = 2*mtrnuml
        end if
        call readmeter(lineq,iccount,mtrnmp,mtrdnp)
c
c  Read past printed time signature; not used in pmxa.
c
        lenbeat = i1fnodur(mtrdenl,'x')
        lenmult = 1
        if (mtrdenl .eq. 2) then
          lenbeat = 16
          lenmult = 2
        end if
        lenbar = lenmult*mtrnuml*lenbeat
        mtrnuml = 0
      else if (charq .eq. 'C') then
        call g1etchar(lineq,iccount,durq)
        if (.not.(index('tsmanrbf',durq).gt.0 .or.
c     *      (ichar(durq).ge.48 .and. ichar(durq).le.54))) then
     *      (ichar(durq).ge.48 .and. ichar(durq).le.55))) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
c     *           'Must have t,s,m,a,n,r,b,f or 1-6 after C!')
     *           'Must have t,s,m,a,n,r,b,f or 1-7 after C!')
          stop 1
        end if
        gotclef = .true.
      else if (charq .eq. 'R') then
        if (ivx .ne. 1) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Repeats can only go in voice 1!')
          stop 1
        end if
10      call g1etchar(lineq,iccount,durq)
        if (index('lrdDb',durq) .gt. 0) go to 10
        if (durq .ne. ' ') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Illegal character after "R" (repeat/double bar)!')
          stop 1
        end if
      else if (charq .eq. 'V') then
c
c  Ending
c
        if (iv .ne. 1) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Voltas are only allowed in voice #1!')
          stop 1
        else if (isvolt) then
          print*
          print*,'*******WARNING********'
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'There is more than one volta in this input block.!')
          print*,'This may work in a score, but WILL NOT work in parts.'
          print*,
     *'Safest to have only 1 volta per block, at the start of the block'
        end if
        isvolt = .true.
11      call g1etchar(lineq,iccount,durq)
        if (durq .ne.' ') go to 11
      else if (charq .eq. 'B') then
        continue
      else if (charq .eq. 'P') then
        if (ivx.ne.1 .or. nnl(1).ne.0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Only allowed at beginning of block!')
          stop 1
        end if
16      call g1etchar(lineq,iccount,durq)
        if (durq.eq.'l'.or.durq.eq.'r'.or.(ichar(durq).ge.48 .and.
     *       ichar(durq).le.57)) go to 16
        if (durq .eq. 'c') then
c
c  Expect a centered name, and it has to be last option
c
          call g1etchar(lineq,iccount,durq)
          if (durq .eq. '"') then
c
c  Quoted name, go to next quote mark
c
            do 35 iccount = iccount+1 , 127
              if (lineq(iccount:iccount) .eq. '"') go to 36
35          continue
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *        'Missing close quote after page number command (P)!')
            stop 1
36          continue
          else if (durq .ne. ' ') then
c
c  Space-delimited name, look for next blank
c
            do 37 iccount = iccount+1 , 127
              if (lineq(iccount:iccount) .eq. ' ') go to 38
37          continue
38          continue
          end if
        else if (durq .ne. ' ') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Only "l","r","c" or digit allowed after "P"!')
          stop 1
        end if
      else if (charq .eq. 'W') then
        call g1etchar(lineq,iccount,durq)
        if (durq .ne. '.') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Next char after " W" must be "."!')
          stop 1
        end if
        call g1etchar(lineq,iccount,durq)
        if (ichar(durq).ge.48 .or. ichar(durq).le.57) then
          wminnh(ibarcnt+nbars+1) = .1*(ichar(durq)-48)
        else
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Next char after " W." must be 0-9!')
          stop 1
        end if
      else if (charq .eq. 'T') then
c
c  Titles
c
        call g1etchar(lineq,iccount,durq)
        if (index('itc',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Must put "i", "t", or "c" after "T"!')
          stop 1
        end if
        ihead = ihead+2**(index('itc',durq)-1)
c
c  Maybe a number after 'Tt', but ignore here.  Read past string on next line.
c
        call read10(charq,lastchar)
        nline = nline+1
        iccount = 128
      else if (charq .eq. 'A') then
27      call g1etchar(lineq,iccount,durq)
        if (index('rbsd',durq) .gt. 0) then
          go to 27
        else if (durq .eq. 'a') then
          call g1etchar(lineq,iccount,durq)
          call readnum(lineq,iccount,durq,fbar)
          iccount = iccount-1
          go to 27
        else if (durq .eq. 'i') then
          call g1etchar(lineq,iccount,durq)
c
c  Local interstaff correction.  Set to -1. if not specifiec, or after use,
c  or anytime except at top, since pmxb handles all times except at top.
c
          call readnum(lineq,iccount,durq,tintstf)
          if (ibarcnt .eq. 0) fintstf = tintstf
          iccount = iccount-1
          go to 27
        else if (durq .eq. 'I') then
c
c  Global interstaff correction.  Use in place of fintstf if fintstf<0
c
          call g1etchar(lineq,iccount,durq)
          call readnum(lineq,iccount,durq,gintstf)
          iccount = iccount-1
          go to 27
        else if (durq .eq. 'o') then
          optimize = .true.
          go to 27
        else if (durq .ne. ' ') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'The only legal entries after "A" are "r,s,b,a,i,I,d,o"!')
          stop 1
        end if
      else if (charq .eq. 'K') then
c
c  Rules and function of K command
c
c  Only 1 K +/-n +/-m  allowed per block if n.ne.0 (transposition).  isig1 is
c  initial sig, and must be passed to pmxb because it is needed when topfile
c  is called, which is before the K+n+m command is read in pmxb.  Also, we
c  compute and save ibrkch and newkey for each syst, accounting for key changes,
c  then adjust fbar to make poenom much more accurate.
c
        call g1etchar(lineq,iccount,durq)
        if (index('+-',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      '"K" (transpose or key change) must be followed by "+,-"!')
          stop 1
        end if
        iccount = iccount+1
        num1 = 44-ichar(durq)
c
c  num1= +1 or -1
c
        call readnum(lineq,iccount,durq,fnum)
        num1 = nint(fnum)*num1
        if (index('+-',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      '1st number after "K" must be followed by "+,-"!')
          stop 1
        end if
        iccount = iccount+1
        num2 = 44-ichar(durq)
        call readnum(lineq,iccount,durq,fnum)
        num2 = num2*int(fnum+.1)
        if (num1 .eq. 0) then
c
c  Key change, only one per block allowed
c
          if (iskchb) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'Only one key change allowed per input block!')
            stop 1
          end if
          iskchb = .true.
          nkeys = nkeys+1
          kchmid(nkeys) = mod(itsofar(ivx),lenbar).ne.0
c
c  Make ibrkch = barnum-1 if at start of bar, so fsyst advances ok at linebreak.
c
          ibrkch(nkeys) = ibarcnt+nbars
          if (kchmid(nkeys)) ibrkch(nkeys) = ibrkch(nkeys)+1
          newkey(nkeys) = num2+idsig
        else
c
c  Transposition
c
          if (ibarcnt .gt. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'Transposition must be at top of first input block!')
            stop 1
          end if
          isig1 = num2
          idsig = isig1-newkey(1)
c
c  idsig is the difference between sig after transposition, and sig in setup.
c  It may alter # of accid's in key changes if there is transposition.
c
        end if
      else if (charq .eq. '|') then
c
c  Optional bar symbol
c
        if (mod(itsofar(ivx),lenbar).ne.0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'Bar line marker out of place!')
          stop 1
        else if (shifton) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'Bar ended with user-defined shift still on!')
          stop 1
        end if
      else if (charq .eq. '/') then
        if (fbon) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'Block ended with forced beam open!')
          stop 1
        else if (shifton) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'Bar ended with user-defined shift still on!')
          stop 1
        else if (gotclef) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'May not enter clef at end of input block!')
          stop 1
        end if
        barend = .false.
c
c  Perform time checks
c
        if (mod(itsofar(ivx),lenbar).ne.0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Block duration not divisible by lenbar!')
          print*,'lenbar is ',lenbar
          stop 1
        else if (ivx.gt.1 .and. itsofar(ivx).ne.itsofar(1)) then
          print*
          print*,'# of bars in voice 1, current voice:',
     *        itsofar(1)/lenbar,itsofar(ivx)/lenbar
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Block duration not equal to voice 1!')
          stop 1
        end if
        call g1etchar(lineq,iccount,durq)
        if (durq .eq. ' ' .and. iv.eq.nv) then
c
c  End of input block
c
          loop = .false.
        else
c
c  Start a new voice
c
          if (lenbr0.ne.0 .and. firstline) lenbar = lenbr0
          nbars = 0
          if (durq .eq. ' ') then
c
c  New voice is on next staff
c
            iv = iv+1
            ivx = iv
          else
c
c  New voice is on same staff.  Set up for it
c
            ivx = nv+1
            do 23 iiv = 1 , nv
              if (nvmx(iiv) .eq. 2) ivx = ivx+1
23          continue
            if (ivx .gt. nm) then
              write(*,'(1x,a21,i3,a23)')'Cannot have more than',nm,
     *          ' lines of music at once'
              stop 1
            end if
            nvmx(iv) = 2
            ivmx(iv,2) = ivx
            itsofar(ivx) = 0
            nnl(ivx) = 0
            do 24 j = 1 , 200
              rest(ivx,j) = .false.
24          continue
c
c  For midi stuff, record that there is a 2nd line of music in this voice
c
            if (ismidi) twoline(iv) = .true.
          end if
        end if
        iccount = 128
      else if (charq .eq. 'S') then
c
c  New nsyst: for use with partmaker scor2prt, for parts w/ diff # of systs.
c
        if (ibarcnt .gt. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           '"S" can only be in first input block!')
          stop 1
        end if
        call g1etchar(lineq,iccount,durq)
        if (index('123456789 ',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'A digit must follow "S"!')
          stop 1
        end if
        call readnum(lineq,iccount,durq,fnsyst)
        nsyst = nint(fnsyst)
14      continue
        if (durq .eq. 'P') then
c
c  New npages for parts.  
c
          call g1etchar(lineq,iccount,durq)
          if (index('123456789 ',durq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Must have a number here!')
            stop 1
          end if
          call readnum(lineq,iccount,durq,fnsyst)
          npages = nint(fnsyst)
          go to 14
        else if (durq .eq. 'm') then
c
c  Reset musize (musicsize).
c
          call g1etchar(lineq,iccount,durq)
          if (index('123456789 ',durq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Must have a number here!')
            stop 1
          end if
          call readnum(lineq,iccount,durq,fnsyst)
          musize = nint(fnsyst)
          wheadpt = whead20*musize
          go to 14
        else if (durq .ne. ' ') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Illegal character in "S" symbol!')
          stop 1
        end if
      else if (charq .eq. 'L') then
        nflb = nflb+1
        ibarflb(nflb) = ibarcnt+nbars+1
        call g1etchar(lineq,iccount,durq)
        if (index('123456789',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'Need integer to define forced line break!')
          stop 1
        end if
        call readnum(lineq,iccount,durq,sysflb)
        isysflb(nflb) = nint(sysflb)
        if (nflb .gt. 1) then
c
c  Check if new number is > prior one
c
          if (isysflb(nflb) .le. isysflb(nflb-1)) then
            call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *       'You already forced a line break at a later line!')
            stop 1
          end if
        end if
        if (npages .eq. 0) then
          print*
          print*,'WARNING! You forced a line break at line ',
     *      isysflb(nflb),' but npage = 0.  Continue?'
          read(*,'(a)') charq
          if (index('yY',charq) .eq. 0) stop 1
        else if (isysflb(nflb) .gt. nsyst) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Forced line break at line num > nsyst!')
          stop 1
        else if (index(' PM',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'Must have " ", "P", or "M" here!')
          stop 1
        end if
        if (durq .eq. 'P') then
c
c  Forced page break here, get page number.
c
          call g1etchar(lineq,iccount,durq)
          if (index('123456789',durq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'Need integer to define forced page break!')
            stop 1
          end if
          call readnum(lineq,iccount,durq,fnum)
          nfpb = nfpb+1
          ipagfpb(nfpb) = nint(fnum)
          isysfpb(nfpb) = isysflb(nflb)
        end if
        if (index(' M',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *        'Illegal character in linebreak symbol!')
          stop 1
        else if (durq .eq. 'M') then
          nmovbrk = nmovbrk+1
          isysmb(nmovbrk) = isysflb(nflb)
          call g1etchar(lineq,iccount,durq)
31        if (durq .eq. '+') then
c
c  Vertical spacing, read past number.
c
            call g1etchar(lineq,iccount,durq)
            if (index('123456789',durq) .eq. 0) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'Integer required here!')
              stop 1
            end if
            call readnum(lineq,iccount,durq,fnum)
            go to 31
          else if (durq .eq. 'i') then
c
c  Change indentation,
c
            call g1etchar(lineq,iccount,durq)
            if (index('.123456789',durq) .eq. 0) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'Decimal number required here!')
              stop 1
            end if
c
c  fracsys was initialized in block data to all 0.'s
c
            call readnum(lineq,iccount,durq,fracsys(nmovbrk))
            go to 31
          else if (durq .eq. 'c') then
            call g1etchar(lineq,iccount,durq)
            go to 31
          else if (durq .eq. 'r') then
            call g1etchar(lineq,iccount,durq)
            if (index('+-',durq) .eq. 0) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'Must have "+" or "-" after "r" as movement break option!')
              stop 1
            end if
            call g1etchar(lineq,iccount,durq)
            go to 31
          else if (durq .eq. 'n') then
c
c  Change # of voices.  Input ninow, iorig(1...ninow).  Will use names,
c  staves per inst. and clefs  corr. to iorig in original list of instruments.
c
            nv = 0
            call g1etchar(lineq,iccount,durq)
            ninow = ichar(durq)-48
            if (ninow.lt.1 .or. ninow.gt.nm) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'New noinst must come here!')
              stop 1
            end if
            do 63 iinow = 1 , ninow
              call g1etchar(lineq,iccount,durq)
              iorig = ichar(durq)-48
              if (iorig.lt.1 .or. iorig.gt.noinst) then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *              'Must enter inst. # from orig. list here!')
                stop 1
              end if
              nv = nv+nsperi(iorig)
63          continue
            do 61 iiv = 1 , nv
c
c  Get clef names
c
              call g1etchar(lineq,iccount,durq)
              if (.not.(index('tsmanrbf',durq).gt.0 .or.
c     *             (ichar(durq).ge.48 .and. ichar(durq).le.54))) then
     *             (ichar(durq).ge.48 .and. ichar(durq).le.55))) then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
c     *          'Must have t,s,m,a,n,r,b,f or 1-6 as clef symbol here!')
     *          'Must have t,s,m,a,n,r,b,f or 1-7 as clef symbol here!')
                stop 1
              end if
c
c  Initialize new voices
c
              nvmx(iiv) = 1
              ivmx(iiv,1) = iiv
              itsofar(iiv) = 0
              nnl(iiv) = 0
              do 62 j = 1 , 200
                rest(iiv,j) = .false.
62            continue
61          continue
c
c  Loop back up, this might not be last option in M
c
            call g1etchar(lineq,iccount,durq)
            go to 31
          else if (durq .ne. ' ') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *        'Illegal character after Movement break symbol!')
            stop 1
          end if
          if (fracsys(nmovbrk) .lt. 0.001) then
c
c  Since fracsys was not explicitly set, set it to prior value.
c
            if (nmovbrk .eq. 1) then
              fracsys(nmovbrk) = fracindent
            else
              fracsys(nmovbrk) = fracsys(nmovbrk-1)
            end if
          end if
        end if
c
c  Just before exiting if-block for forced line breaks, set counter to use when 
c  dealing with vertical space calcs
c
        nistaff(nflb) = nv-1
      else if (charq .eq. 'F') then
        usefig = .false.
      else if (charq .eq. 'X') then
        call g1etx(lineq,iccount,.true.,shifton,ibarcnt-ibaroff+nbars+1,
     *             udsp(ibarcnt+nbars+1),wheadpt)
      else if (charq .eq. 'I') then
c
c  MIDI settings.  
c
        if (ivx.ne.1 .or. nnl(1).ne.0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *     'MIDI stuff only allowed at start of block!')
          stop 1
        end if
        ismidi = .true.
        call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar,
     *               mtrdenl,.true.)
      else if (charq .eq. 'M') then
        call setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,ivx,
     *                 nline)
      else
        call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'Illegal character!')
        print*,'ASCII code:',ichar(charq)
        stop 1
      end if
      return
      end
      subroutine g1etchar(lineq,iccount,charq)
      parameter(nm=12)
      common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
     *     fracindent,nsperi(nm)
      logical lastchar,issegno,isheadr,isvolt,fbon
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      logical mrecord,mplay,endmac
      character*1 charq
      character*128 lineq,lnholdq
c
c  Gets the next character out of lineq*128.  If pointer iccount=128 on entry,
c  then reads in a new line.  Resets iccount.  Ends program if no more input.
c
      if (iccount .eq. 128) then
        call read10(lineq,lastchar)
        if (lastchar) return
        if (.not.endmac) then
          iccount = 0
          if (.not.mplay) nline = nline+1
        else
          endmac = .false.
          iccount = icchold
          lineq = lnholdq
        end if
        if (mrecord) then
          call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
        end if
      end if
      iccount = iccount+1
      charq = lineq(iccount:iccount)
      return
      end
      function i1fnodur(idur,dotq)
        character*1 dotq
        if (idur .eq. 6) then
          i1fnodur=1
        else if (idur .eq. 3) then
          i1fnodur=2
        else if (idur .eq. 1) then
          i1fnodur=4
        else if (idur .eq. 8) then
          i1fnodur=8
        else if (idur .eq. 4) then
          i1fnodur=16
        else if (idur .eq. 2) then
          i1fnodur=32
        else if (idur .eq. 0) then
          i1fnodur=64
        else if (idur .eq. 16) then
c
c  Only used for denominator of time signatures, not for notes
c
          i1fnodur=4
        else if (idur .eq. 9) then
          i1fnodur = 128
        else
          print*
          print*,'You entered an invalid note-length value:',idur
          stop 1
        end if
        if (dotq .eq. 'd') i1fnodur = i1fnodur*3/2
      return
      end
      subroutine makeabar()
c
c  On input, have pseudo-durations in nodur(ivx,ip).  Not real durations for
c    xtups, since only last note of xtup gets non-zero nodur, which 
c    corresponds to single note of full length of xtup.
c  In this subroutine we make an ordered list of all notes in all voices.
c    ilnc      = list note counter
c    ivxo(ilnc), ipo(ilnc) = voice# and position in voice of ilnc-th note.
c    to(ilnc)  = real duration of the note in PMX-units (64=whole note)
c    tno(ilnc) = time to next event in the bar.   
c    tnote(ilnc) = actual duration of note
c  Then run thru list, grouping consecutive notes into \notes groups ib.  
c    space(ib) = real time unit for the \notes group 
c    squez(ib) = factor on space to get effective space.  This will be 1 if
c                there is a note exactly spanning each interval of space, and
c                <1 if not.  
c  Details:  let eon = elemskips per noteskip (like length).  Basic formula is
c    eon = sqrt(space/2.)  
c  If tgovern >= space, then 
c    eon = sqrt(tgovern/2)*(space/tgovern) = space/sqrt(2*tgovern). 
c  Time needed to give this eon using basic formula is
c    teq = space**2/tgovern
c  Factor on space to get teq is
c    squez(ib) = space/tgovern
c  The eon for each ib can then be computed based on time of space*squez.
c  Iff squez = 1, there is a note spanning every increment in the \notes group.
c
c    tnminb = minimum time span in the bar for increments spanned by notes,
c             i.e., with squez=1.  Use after parsing into line to decide if
c             spacing needs to be "flattened" among notes groups.   
c
      common /comtol/ tol
      parameter (nm=12,nkb=600)
      common /a1ll/ iv,ivxo(200),ipo(200),to(200),tno(200),nnl(nm),
     *   nv,ibar,mtrnuml,nodur(nm,200),lenbar,iccount,
     *   nbars,itsofar(nm),nib(nm,15),nn(nm),
     *   rest(nm,200),lenbr0,lenbr1,firstline,newmeter
      common /linecom/ elskb,tnminb(nkb)
      common /c1omnotes/ nnodur,wminnh(nkb),nnpd(2000),durb(2000),iddot,
     *     nptr(nkb),ibarcnt,mbrest,ibarmbr,
     *     ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(2000)
      common /c1ommvl/ nvmx(nm),ivmx(nm,2),ivx,fbar
      logical rest,firstline,newmeter,gotclef
      integer cnn(nm),istart(80),istop(80)
      real*4 xit(nm),space(80),tstart(80),squez(80),tnote(200)
      elskb = 0.
      tnminb(ibarcnt) = 1000.
      do 1 iv = 1 , nv
      do 1 kv = 1 , nvmx(iv)
        ivx = ivmx(iv,kv)
        if (ibar .gt. 1) then
          nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1)
        else
          nn(ivx) = nib(ivx,ibar)
        end if
1     continue
c
c initialize list note counter, time(iv), curr. note(iv)
c
      ilnc = 1
      do 4 iv = 1 , nv
      do 4 kv = 1 , nvmx(iv)
        ivx = ivmx(iv,kv)
        cnn(ivx) = 1
        ivxo(ilnc) = ivx
        ipo(ilnc) = 1
        to(ilnc) = 0.
        tnote(ilnc) = fnote(nodur,ivx,1)
        xit(ivx) = tnote(ilnc)
        if (abs(xit(ivx)-lenbar).lt.tol) xit(ivx) = 1000.
        ilnc = ilnc+1
4     continue
c
c  Build the list
c
5     continue
c
c  Determine which voice comes next from end of notes done so far.
c  tmin is the earliest ending time of notes done so far
c
      tmin = 1000.
      do 6 iv = 1 , nv
      do 6 kv = 1 , nvmx(iv)
        ivx = ivmx(iv,kv)
        tminn = min(tmin,xit(ivx))
        if(tminn .lt. tmin) then
          tmin = tminn
          ivnext = ivx
        end if
6     continue
      if (tmin .gt. 999.) go to 7
      ivxo(ilnc) = ivnext
      cnn(ivnext) = cnn(ivnext)+1
      ipo(ilnc) = cnn(ivnext)
      to(ilnc) = tmin
c
c  Check if this voice is done
c
      tnote(ilnc) = fnote(nodur,ivnext,cnn(ivnext))
      if (cnn(ivnext) .eq. nn(ivnext)) then
        xit(ivnext) = 1000.
      else
        xit(ivnext) = xit(ivnext)+tnote(ilnc)
      end if
      ilnc = ilnc+1
      go to 5
7     continue
      ntot = ilnc-1
      do 8 in = 1 , ntot-1
        tno(in) = to(in+1)-to(in)
8     continue
      tno(ntot) = fnote(nodur,ivxo(ntot),ipo(ntot))
      tnote(ntot) = tno(ntot)
c
c  Debug writes
c
c      write(*,'()')
c      write(*,'(16i5)')(ivxo(in),in=1,ntot)
c      write(*,'(16i5)')(ipo(in),in=1,ntot)
c      write(*,'(16f5.1)')(to(in),in=1,ntot)
c      write(*,'(16f5.1)')(tno(in),in=1,ntot)
c      write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot)
c      write(*,'(16f5.1)')(tnote(in),in=1,ntot)
c
c  Done w/ list.  Initialize loop for building note blocks:
c
      ib = 1
      istart(1) = 1
      space(1) = 0.
      in = 1
c
c  Start the loop
c
9     continue
        if (in .eq. ntot) then
          if (space(ib) .lt. tol) then
            space(ib) = tno(in)
c
c  Last gap in bar is spanned by a note, so cannot need a squeeze. 
c
            squez(ib) = 1.
          end if
          istop(ib) = ntot
c
c From here flow out of this if block and into block-setup
c
        else if (space(ib) .lt. tol) then
c
c space hasn't been set yet, so tentatively set:
c
          space(ib) = tno(in)
          if (space(ib) .lt. tol) then
            in=in+1
          else
c
c  Tentative space tno(in) is non-zero. Set squez, which will be kept (since
c    it is a unique property of the particular increment starting here) :
c
            squez(ib) = getsquez(in,ntot,space(ib),tnote,to)
            istop(ib) = in
          end if
          go to 9
        else if (tno(in+1) .lt. tol) then
c
c This is not the last note in the space, so
c
          in = in+1
          go to 9
        else if (abs(tno(in+1)-space(ib)) .lt. tol) then
c
c  Next increment has same space.  Does it have same squez?
c
          xsquez = getsquez(in+1,ntot,space(ib),tnote,to)
c
c  If it does have the same squez, loop, otherwise flow out
c
          if (abs(xsquez-squez(ib)) .lt. tol) then
c
c Keep spacing the same, update tentative stop point
c
            in = in+1
            istop(ib) = in
            go to 9
          end if
        end if
c
c At this point istart, istop, space, and squez are good, so close out block
c
        tstart(ib) = to(istart(ib))
c
c  Compute elemskips assuming no flattening to increase min space.  The formula
c  is only correct if f1eon(t) = sqrt(t/2); more generally (after possible
c  flattening in pmxb), elsperns = squez*feon(space/squez)
c
        elsperns = f1eon(space(ib)*squez(ib))
        if (istop(ib) .eq. ntot) then
          nnsk = nint((lenbar-tstart(ib))/space(ib))
        else
          nnsk = nint((to(istop(ib)+1)-tstart(ib))/space(ib))
        end if
        elskb = elskb+elsperns*nnsk
        if (nptr(ibarcnt+1) .gt. nptr(ibarcnt)) then
          call catspace(space(ib),squez(ib),nnsk)
        else
c
c  This is the first entry for this bar
c
          nnpd(nptr(ibarcnt)) = nnsk
          durb(nptr(ibarcnt)) = space(ib)
          sqzb(nptr(ibarcnt)) = squez(ib)
          nptr(ibarcnt+1) = nptr(ibarcnt+1)+1
        end if
c
c  Update minimum space spanned by a note
c
        if (abs(squez(ib)-1) .lt. tol) 
     *       tnminb(ibarcnt) = min(tnminb(ibarcnt),space(ib))
        if (istop(ib) .eq. ntot) go to 15
c
c  End of spatial accounting for now
c
        ib = ib+1
        istart(ib) = istop(ib-1)+1
        in = istart(ib)
c
c Set tentative block space for new block
c
        space(ib) = tno(in)
        if (space(ib).gt.tol) 
     *        squez(ib)= getsquez(in,ntot,space(ib),tnote,to)
        istop(ib) = in
      go to 9
15    continue
c     nb = ib
c
c  Debug writes
c
c      write(*,'(16i5)')(istart(ib),ib=1,nb)
c      write(*,'(16i5)')(istop(ib),ib=1,nb)
c      write(*,'(16f5.1)')(space(ib),ib=1,nb)
c      write(*,'(16f5.1)')(squez(ib),ib=1,nb)
c
      return
      end
      function f1eon(time)
        f1eon = sqrt(time/2)
      return
      end
      subroutine catspace(space,squez,nnsk)
      parameter (nkb=600)
      common /c1omnotes/ nnodur,wminnh(nkb),nnpd(2000),durb(2000),iddot,
     *     nptr(nkb),ibarcnt,mbrest,ibarmbr,
     *     ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(2000)
      common /comtol/ tol
      logical gotclef
      do 16 iptr = nptr(ibarcnt) , nptr(ibarcnt+1)-1
        if (abs(space-durb(iptr)) .lt. tol) then
          if (abs(squez-sqzb(iptr)) .lt. tol) then
c
c  Increment pre-existing entry
c
            nnpd(iptr) = nnpd(iptr)+nnsk
            return
          end if
        end if
16    continue
c
c  Didn't find current duration & squez, so add a new entry.
c  No particular reason to keep in order, so add at the end.
c
      nnpd(nptr(ibarcnt+1)) = nnsk
      durb(nptr(ibarcnt+1)) = space
      sqzb(nptr(ibarcnt+1)) = squez
      nptr(ibarcnt+1) = nptr(ibarcnt+1)+1
      return
      end
      subroutine chklit(lineq,iccount,literr)
      character*128 lineq
      character*1 charq,chax
      literr = 0
      itype = 1
17    call g1etchar(lineq,iccount,charq)
      if (charq .eq. chax(92)) then
        itype = itype+1
        if (itype .gt. 3) then
          literr = 1
          return
        end if
        go to 17
      end if
      lenlit = itype
18    call g1etchar(lineq,iccount,charq)
      if (charq.eq.chax(92)) then
        call g1etchar(lineq,iccount,charq)
        if (charq .ne. ' ') then
c
c  Starting a new tex command withing the string
c
          lenlit = lenlit+2
          if (lenlit .gt. 128) then
            literr = 2
            return
          end if
          go to 18
        end if
      else
        lenlit = lenlit+1
        if (lenlit .gt. 128) then
          literr = 2
          return
        end if
        go to 18
      end if
      return
      end
      subroutine errmsg(lineq,iccount,ibarno,msgq)
      parameter(nm=12)
      common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
     *     fracindent,nsperi(nm)
      logical lastchar,fbon,issegno,isheadr,isvolt
      character*128 lineq
      character*78 outq
      character*(*) msgq
      character*1 chax
      if (iccount .le. 78) then
        outq = lineq(1:78)
        iposn = iccount
      else
        outq = '... '//lineq(55:128)
        iposn = iccount-50
      end if
      print*
      ndigbn = max(1,int(log10(ibarno+.1)+1))
      ndignl = int(log10(nline+.1)+1)
      lenmsg = index(msgq,'!')-1
c
c  Split off msgq(..) sinve UNIX compilers don't allow concat substring!!!
c
      write(*,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)//
     *',$)')' ERROR in line ',nline,', bar ',ibarno
      write(*,'(1x,a)')msgq(1:lenmsg)
      write(15,'(/,a15,i'//chax(48+ndignl)//',a6,i'//chax(48+ndigbn)//
     *',$)')' ERROR in line ',nline,', bar ',ibarno
      write(15,'(a)')msgq(1:lenmsg)
      i10 = iposn/10
      i1 = iposn-10*i10
      write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v'
      write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'v'
      print*,outq(1:78)
      write(15,'(a)')' '//outq(1:78)
      write(*,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^'
      write(15,'('//chax(48+i10)//chax(48+i1)//'x,a)')'^'
      open(19,file='pmxaerr.dat')
      write(19,'(i6)') nline
      close(19)
      return
      end
      block data
      common /comtol/ tol
      common /comtrans/ ntrans,cheadq
      common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:40),
     *      isysflb(0:40),npages,nfpb,ipagfpb(0:18),isysfpb(0:18),
     *      usefig,fintstf,gintstf,fracsys(20),nmovbrk,isysmb(0:20),
     *      nistaff(0:40)
      common /cblock/
     *      etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
     *      xilbn,xilbtc,xilhdr,xilfig,a,b,inhnoh
      common /cominbot/ inbothd
      logical usefig
c
c      block data
c
      common /comstart/ facmtr
      character*60 instrq,titleq,compoq,cheadq
      logical headlog
      common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
     *    inhead
      common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
     *                flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
     *                rtshfac
      common /combmh/ bmhgt,clefend
      data tol /.001/
      data cheadq 
     *  /'                                                            '/
      data gslfac /9./
      data instrq,titleq,compoq,headlog /3*' ',.false./
c
c  meter space (pts) = xb4mbr = musicsize*facmtr
c
      data facmtr /0.7/
      data grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
     *                flagfac,dotfac,bacfac,agc1fac,clefend,bmhgt
     * / 1.3333,.4   ,   .7 ,  .3  ,  0.2 ,  2.0 , 1.0 ,
     *               .7,.7 ,.9 ,.5 ,2.3 ,1.1  /
      data rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,arpfac
     *  /   1.32 ,  2.25   ,  0.47 , 0.83  ,   0.17 , 0.5 ,  1.7   /
      data rtshfac / 1.0 /
c
c  From other
c
      data ptheight,widthpt,
     *      etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
     *      xilbn,xilbtc,xilhdr,xilfig,a,b,inbothd,inhnoh
     *   / 740. , 524. ,
     *   .50  ,  .25  , 0.4 , 0.4  , 0.2 , 12. ,21. , 12.,
     *    4   ,   1.6 ,5.,5.7,1.071,2.714,16 ,16 /
      data fracsys /20*0./
      end
      subroutine m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
c
c  This is called when (a) macro recording is just starting and
c  (b) at the start of a new line, if recording is on
c
      character*128 lineq,lnholdq
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
     *                 ic1mac(20),ilmac,iplmac
      logical mrecord,mplay,endmac
      character*65536 bufq
      integer*2 lbuf(2000)
      common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
	lbuf(1) = lbuf(1)
      if (.not.mrecord) then
c
c  Starting the macro
c
        ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount
        il1mac(macnum) = ilbuf-1
        ic1mac(macnum) = iccount
        mrecord = .true.
      end if
      if (iccount .lt. 128) then
        ndxm = index(lineq(iccount+1:128),'M')
        if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M',
     *                                  128-iccount)
        if (ndxm .gt. 0) then
c
c  This line ends the macro.
c
          if (lineq(iccount+ndxm+1:iccount+ndxm+1) .ne. ' ') then
            call errmsg(lineq,iccount+ndxm+1,ibarcnt-ibaroff+nbars+1,
     *           'Improper macro termination!')
            stop 1
          end if
          ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm
          il2mac(macnum) = ilbuf-1
          mrecord = .false.
        end if
      end if
      return
      end
      subroutine setmac(lineq,iccount,ibarcnt,ibaroff,nbars,charq,durq,
     *                  ivx,nline)
      character*1 charq,durq
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      logical mrecord,mplay,endmac,btest
      character*128 lnholdq,lineq
      common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
     *                 ic1mac(20),ilmac,iplmac
c
c  Macro action
c
      call g1etchar(lineq,iccount,charq)
      if (charq.eq.'S' .and. ivx.ne.1) then
        print*
        print*
        print*,'*********WARNING*********'
        call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *    '"MS..." only put in parts by scor2prt if in voice #1!')
      end if
      if (index('RSP ',charq) .eq. 0) then
        call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Illegal character after "M" (macro)!')
        stop 1
      else if (charq .ne. ' ') then
c
c  Record or playback a macro.  Get the number of the macro.
c
        call g1etchar(lineq,iccount,durq)
        if (index('123456789',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Must input number after "MR","MP", or "MS"!')
          stop 1
        end if
        call readnum(lineq,iccount,durq,fnum)
        macnum = nint(fnum)
        if (durq .ne. ' ') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Macro number must be followed by a blank!')
          stop 1
        end if
        if (index('RS',charq ).gt. 0) then
c
c  Record or save a macro
c
          if (macnum.lt.1 .or. macnum.gt.20) then
            call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *           'Macro number not in range 1-20!')
            stop 1
          else if (btest(macuse,macnum)) then
            print*
            print*,'WARNING: Redefining macro # ',macnum
          end if
          macuse = ibset(macuse,macnum)
          if (charq .eq. 'R') then
            call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
          else if (charq .eq. 'S') then
c
c  Save (Record but don't activate)
c
1           call m1rec1(lineq,iccount,ibarcnt,ibaroff,nbars,ndxm)
            if (mrecord) then
              call getbuf(lineq)
              nline = nline+1
              iccount = 0
              go to 1
            end if
            iccount = iccount+ndxm+1
          end if
        else
c
c  Playback the macro
c
          if (.not.btest(macuse,macnum)) then
            call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *           'Cannot play a macro that has not been recorded!')
            stop 1
          end if
          icchold = iccount
          lnholdq = lineq
          iccount = 128
          mplay = .true.
          ilmac = il1mac(macnum)
        end if
      end if
      return
      end
      subroutine g1etset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
     *    xmtrnum0,newkey,npages,nsyst,musize,bottreb)
      parameter(nm=12)
      character*65536 bufq
      character*1 chax
      integer*2 lbuf(2000)
      common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
      character*128 lineq
      logical lastchar,issegno,isheadr,isvolt,fbon,bottreb,
     *        newway
      common /c1omget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt,
     *     fracindent,nsperi(nm)
c
c  Get the first line
c
      iccount = 0
      nline = 1
9     call getbuf(lineq)
      if (lineq(1:1) .eq. '%') then
        nline = nline+1
        go to 9
      end if
      if (lineq(1:3) .eq. '---') then
c
c  Have TeX input until next line that starts with '---'
c
3       nline = nline+1
        call getbuf(lineq)
        if (ilbuf .gt. nlbuf) go to 1
        go to 2
1       print*,'You did not terminate type 0 TeX input with "---"'
        stop 1
2       continue
        if (lineq(1:3) .ne. '---') go to 3
c
c  Force a new line read on first call to readin
c
        iccount = 128
      end if
c
c  Here, lineq and nline are first non-TeX lines.
c
      nv = nint(readin(lineq,iccount,nline))
      if (nv .gt. nm) then
        write(*,'(1x,a30,i3)')'Number of voices cannot exceed',nm
        stop 1
      end if
      noinst = nint(readin(lineq,iccount,nline))
      newway = noinst.le.0
      if (newway) noinst = -noinst
      do 10 iinst = 1 , noinst
c
c  Seve # of staves per inst in case later drop some inst's.
c
        if (newway) then
          nsperi(iinst) = nint(readin(lineq,iccount,nline))
        else if (iinst .gt. 1 ) then
          nsperi(iinst) = 1
        else
          nsperi(iinst) = nv-noinst+1
        end if
10    continue
      mtrnuml = nint(readin(lineq,iccount,nline))
      mtrdenl = nint(readin(lineq,iccount,nline))
cc
cc  Kluge!!!
cc
c      if (mtrdenl .eq. 1) then
c        mtrdenl = 2
c        mtrnuml = mtrnuml*2
c      end if
      mtrnmp = nint(readin(lineq,iccount,nline))
      mtrdnp = nint(readin(lineq,iccount,nline))
      xmtrnum0 = readin(lineq,iccount,nline)
      newkey = nint(readin(lineq,iccount,nline))
      npages = nint(readin(lineq,iccount,nline))
      nsyst = nint(readin(lineq,iccount,nline))
      musize = nint(readin(lineq,iccount,nline))
      fracindent = readin(lineq,iccount,nline)
      if (npages .gt. nsyst) then
        print*,'Error in input file: npages > nsyst'
        stop 1
      end if
c
c  Next noinst non-comment lines are names of instruments.
c
      do 4 i = 1 , abs(noinst)
5       call getbuf(lineq)
        nline = nline+1
        if (lineq(1:1) .eq. '%') go to 5
4     continue
c
c  Mext non-comment line has nv clef names
c
6     call getbuf(lineq)
      nline = nline+1
      if (lineq(1:1) .eq. '%') go to 6
      do 7 iv = 1 , nv
c        if (index('brnamstf0123456',lineq(iv:iv)) .eq. 0) then
        if (index('brnamstf01234567',lineq(iv:iv)) .eq. 0) then
          call errmsg(lineq,iv,0,
     *       'There should be a clef symbol here!')
          stop 1
        end if
7     continue
      if (lineq(nv+1:nv+1) .ne. ' ') then
        call errmsg(lineq,nv+1,0,
     *    'There should be a blank here!')
        stop 1
      end if
c
c Set flag if voice 1 is treble, since it affects vertical spacing
c
      bottreb = lineq(1:1).eq.'t'
c
c  Mext non-comment line has path name
c
8     call getbuf(lineq)
      nline = nline+1
      if (lineq(1:1) .eq. '%') go to 8
      lpath = index(lineq,' ')-1
      if (index('/:'//chax(92),lineq(lpath:lpath)) .eq. 0) then
        call errmsg(lineq,lpath,0,
     *       'Last character of pathname is not "/",":", or "'
     *                                        //chax(92)//'"!')
        stop 1
      end if
      return
      end
      subroutine checkdyn(lineq,iccount,ibar)
      character*128 lineq
      character*1 durq,chax
      character*4 dynsymq
      do 1 iend = iccount+2 , 128
        ipm = index('- +',lineq(iend:iend))
        if (ipm .gt. 0) go to 2
1     continue
2     continue
      if (iend-iccount.gt.5 .or. iend-iccount.lt.2) then
        call errmsg(lineq,iend-1,ibar,
     *      'Wrong length for dynamic mark!')
        stop 1
      end if
      read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')')
     *   dynsymq
      idno = (index('ppppppp pp  p   mp  mf  f   fp  sf  ff  fff ffff',
     *         dynsymq)+3)/4
      if (idno .eq. 0) then
        call errmsg(lineq,iccount+1,ibar,'Illegal dynamic mark!')
        stop 1
      end if
      iccount = iend
      if (ipm .ne. 2) then
c
c  There is a vertical shift, have "+" or "-"
c
        iccount = iccount+1
        if (index('0123456789',lineq(iccount:iccount)) .eq. 0) then
          call errmsg(lineq,iccount,ibar,
     *       'Expected integer here for vertical offset!')
          stop 1
        end if
        call readnum(lineq,iccount,durq,fnum)
        idno = nint(fnum)
        if (idno .gt. 31) then
          call errmsg(lineq,iccount-1,ibar,
     *      'Vertical offset for dynamic mark must be (-31,31)!')
          stop 1
        end if
        ipm = index('- +',durq)
        if (ipm .eq. 0) then
          call errmsg(lineq,iccount,ibar,
     *      'Expected "+", "-", or blank here!')
          stop 1
        end if
        if (ipm .ne. 2) then
c
c  There is a horizontal shift
c
          iccount = iccount+1
          if (index('.0123456789',lineq(iccount:iccount)) .eq. 0) then
            call errmsg(lineq,iccount,ibar,
     *       'Expected number here for horizontal offset!')
            stop 1
          end if
          call readnum(lineq,iccount,durq,fnum)
          idno = nint(10*fnum)
          if (idno .gt. 63) then
            call errmsg(lineq,iccount-1,ibar,
     *        'Horizontal offset for dynamic mark must be (-6.3,6.3)!')
            stop 1
          else if (durq .ne. ' ') then
            call errmsg(lineq,iccount,ibar,
     *        'There should be a blank here!')
            stop 1
          end if
        end if
c
c  iccount should be on the blank at the end of the entire symbol
c
      end if
      return
      end
      subroutine g1etx(lineq,iccount,notxtup,shifton,ibar,udsp,wheadpt)
c
c  Parse "X" commands.  Ignore all "B"; "P" means to ignore whole symbol.
c  In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols.
c
      logical notxtup,shifton,number,btest
      character*128 lineq
      character*1 charq,dumq
      number = .false.
      nPBSc = 0
1     call g1etchar(lineq,iccount,charq)
      if (index('PBS:',charq) .gt. 0) then
c
c  Continue checking here even if "P".
c
        ipbsc = index('PBS:',charq)
        if (btest(nPBSc,ipbsc)) then
          call errmsg(lineq,iccount,ibar,'Only one allowed per symbol!')
          stop 1
        else if (.not.notxtup .and. ipbsc.gt.2) then
          call errmsg(lineq,iccount,ibar,'Not allowed in xtuplet!')
          stop 1
        end if
        nPBSc = ibset(nPBSc,ipbsc)
        go to 1
      else if (index('+-.0123456789',charq) .gt. 0) then
        number = .true.
        if (index('+-',charq) .gt. 0) then
          call g1etchar(lineq,iccount,dumq)
          if (index('.0123456789',dumq) .eq. 0) then
            call errmsg(lineq,iccount,ibar,'Expected a number here!')
            stop 1
          end if
        end if
        call readnum(lineq,iccount,dumq,fnum)
        if (charq.eq.'-') fnum = -fnum
        if (dumq .ne. 'p') then
          iccount = iccount-1
          fnum = fnum*wheadpt
        end if
        go to 1
      else if (charq .ne. ' ') then
        call errmsg(lineq,iccount,ibar,'Not allowed in "X" symbol!')
        stop 1
      end if
c
c  Done with parsing.  Other checks
c
      if (iand(6,nPBSc).eq.6 .or. iand(24,nPBSc).eq.24) then
        call errmsg(lineq,iccount-1,ibar,
     *     'Cannot have both "P" and "B" or "S" and ":"!')
        stop 1
      end if
      if (btest(nPBSc,4)) then
        if (number) then
          if (shifton) then
            call errmsg(lineq,iccount-1,ibar,
     *            'Started a group shift without stopping prior one!')
            stop 1
          else
            shifton = .true.
          end if
        else
          if (.not. shifton) then
            call errmsg(lineq,iccount-1,ibar,
     *            'Ended a group shift without starting one!')
            stop 1
          else
            shifton = .false.
          end if
        end if
      end if
c
c  P off, S off, c off => normal user-defined space.  Add to udsp (later fsyst)
c
      if (iand(nPBSc,26).eq.0) udsp = udsp+fnum
      if (.not.number .and. .not.btest(nPBSc,4)) then
        call errmsg(lineq,iccount-1,ibar,
     *      'Must have either a number or a colon in "X" symbol!')
        stop 1
      end if
      return
      end
      subroutine pmxb(inlast,poevec,ncalls,optimize)
cccccccccccccccccccccccccc
cc
cc To Do
cc
cc  Resolve disagreement in final poe for 1st system, compared with *.mx2
cc  Shift slurs on right- or left-shifted main notes (2/7/99)
cc  Various end-of-input-block repeat problems (ick142.pmx).
cc  Force multiplicity for un-beamed xtups.
cc  Clef change at end of piece
cc  Global "A" option to maximize "X" at a given time tick.
cc  Tighten test for end-of-bar hardspace, flgndv(ivx) due to right-shifted
cc       note.  See trubl18.pmx
cc  Tab character as space.
cc  Clef interference with second line of music.
cc  Add space for interferences between *different* lines of music?
cc  Shift arpeggios, both automatic and manual.
cc  Different musicsize for different instruments.
cc  Spacing checks for accid's on left-shifted chord notes
cc  Spacing checks for double dots
cc  Allow forced line breaks w/o setting nsyst.
cc  Cresc-Decresc. (Enhance MusiXTeX first?)
cc  Dynamic Marks.
cc  Bug with Voltas at line end (MusiXTeX problem?).
cc  Subtle bug w/ slur hgt over line brk, see trubl15.pmx
cc  Stem-end slurs.
cc  Allow units in indentation.
cc  Make inline TeX more context sensitive.
cc  Werner's 4/2/98 problem with "o?"
cc  Scor2prt converts e.g. "r0+0" into "r0 0", which seems to be wrong.
cc    converts e.g. "r2db" into "r2d", which might be wrong.
cc  Werner's generalsignature problem with Key change and new transposition.
cc    (wibug8.pmx)
cc  Unequal xtuplets
cc  Print both sets of bar #'s in tex file.
cc  Make barlines invisible \def\xbar{\empty} , fix fbar.
cc  Auto-tie slurs  'At'
cc  Forced line break anywhere (e.g. at a mid-bar repeat).
cc  Clef change at very start of file.
cc  Tighten test for M as macro terminator.
cc  Fix title so not separate limit on author length + composer length.
cc  Arpeggios in xtups.
cc
cc mx10b
cc  Option for instrument name at top center. Last item in P command:
cc    P[n]c         text is instrument name (use in parts)
cc    P[n]cstuff    text is stuff (up to 1st blank)
cc    P[n]c"stuff with spaces"   text is stuff with spaces
cc
cc Post version 1.43
cc  Reduced space rqmt for multiplicity-0 graces (no flag)
cc  Removed last sepsym in centered whole-bar rests, fixes volta height bug.
cc
cc Version 1.43
cc  Fix spacing for end-of-line signature change.
cc  Adjust left-shift of grace group for shifted accidentals.
cc  Put in extra space for left-shifted accidentals.
cc  Fix bug with dot-shift before accid-shift on chord note.
cc  Space-check for right-shifted main notes.
cc  Enable forcing stem direction of single notes in non-beamed xtups.
cc  Disallow clef change after last note before end of input block (pmxa)
cc  Print meter change before page break
cc  increase length of strings for \titles macro
cc version 1.42
cc  Loosen up input syntax for "X" commands.  Subroutine getx()
cc  "B" and "P" in "X" commands
cc mx09b
cc  Allow multiple rests at start of xtup
cc  Add 64th rest
cc  Fix xtup numbers over rests. (subroutine levrn)
cc  Initialize notcrd=.false. every gulp. Avoids undefined state with e.g.
cc    c za / ( c a ...
cc  Allow double dots to be shifted.
cc  Fix spacing with double dotted notes; permit splitting small note.
cc  Fix \dotted printout so it works with old compiler
cc mx08b
cc  Automatic spaces if needed for shifted accidentals.
cc  Some Dynamics
cc  Increase accid. horiz. shift resolution to .o5 (use one more bit in nacc)
cc version 1.41
cc  Allow ":" as last char of path name
cc  Dotted slurs "sb"
cc  Continue bar numbering at movement break "L[integer]Mc"
cc mx07b
cc  Whole-bar rests with double lines of music.  Fixed all options ?
cc  Shift accidentals, either [+|-][integer][+|-][number] or [<|>][number].
cc  Option to suppress centering full-bar rests. "o"
cc mx06b
cc  Shift accid on left-shifted chord note.
cc  Rest as first note of xtup.
cc  Wrong slopes with small widths.  Scale slfac1 by widthpt_default/widthpt
cc  Allow Rb for single bar at movemnet break or end of piece. (islur(25))
cc  Change # of inst at a movement break.  noinst is total # and must be used
cc    in 1st movement.  ninow is current.  nspern(1,...,ninow) is current
cc    staves/inst, nsperi(1,...,noinst) is original.  rename tells whether to
cc    reprint names in parindent at a movement break.  Default is .false.
cc    unless ninow changes, then .true.  But can force either with r+/- as
cc    option in 'M'
cc mx04b
cc  Double-dotted notes, separate+beamed, main+chord, still no extra space.
cc  ???  Don't shift slur ends on whole notes.
cc  (pmxa) Write line number of error in pmxaerr.dat
cc mx02b
cc  Admit "RD" before "/" (search for "rptfq2:" )
cc  In doslur, for multi-line staves, single notes, check forced stem dir'n
cc    before setting stemup (used to set horiz offset).
ccccccccccccccccccccccccccccccc
      parameter (nm=12,nks=125,mv=24576)
c
c  FYI /all/ differs in appearance in function ncmid
c
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
c
c  islur is used as a bank of switches
c
c  bit  meaning
c  0     slur activity on this note
c  1     t-slur here.
c  2     force 0-slope beam starting on this note
c  3     Double dotted note!
c  4     grace before main note
c  5     left repeat
c  6     right repeat
c  7     start Volta
c  8     doublebar
c  9     end Volta
c  10    on=>endvoltabox
c  11    on=>clefchange
c  12-14 0=>treble, ... , 6=>bass
c  15    on=> start new block for clef change (maybe diff. voice)
c  16    literal TeX string
c  17    1=up, 0=down stem for single note (override) See bit 30!
c  18    if on, prohibit beaming
c  19    if on, full bar rest as pause
c  20    Beam multiplicity down-up
c  21    Forced multiplicity for any beam including xtups
c  22-24 Value of forced multiplicity
c  25    single barline at movement break
c  26    doubleBAR (see bits 5,6,8)
c  27-28 Forced beam fine-tune height (1 to 3)
c  29    Blank rest
c  30    If on, get stem dir'n from bit 17
c  31    If on, suppress printing number with xtuplet starting here
c
c
c  Bit values for 2nd bank of switches, ipl
c
c  0-7   Location in list [0,200]
c  8     \loff
c  9     \roff
c  10    chord present?
c  11-16 Forced beam height adjustment (-30 to +30)
c  17-22 Forced beam slope adjustment (-30 to +30)
c  23-26 Slur index for Way-after grace.  Inserted when slur is started.
c  27      Unused?
c  28    key change: only in voice 1
c  29    Grace after main note. (Type A)
c  30    In forced beam.  Signals need to check beam heights
c  31    Grace way after main note. (stretch to next note, type W)
c
c  Set up iornq as bitmap.
c  0     Ornament "(".  Was user-defined horizontal slur shift on this note
c               until 9/24/97; changed that to irest(21)
c  1-13  stmgx+Tupf._)
c  14    Down fermata, was F
c  15    Trill w/o "tr", was U
c  16-18 Editorial s,f,n
c  19-20 >^
c  21    "?" for editorial accid, w/ or w/o s,f,n
c  22    Set if ihornb governs ornament height.  Same in icrdorn.
c  23    Set in getorn if ANY note at time of this main note has ornament.
c             This is ONLY used in beamstrt to signal whether to do more
c             tests for whether ihornb is needed.  (ihornb is only needed
c             if nonchord+upbm, chord+upbm+top_note, chord+dnbm+bot_note)
c  24    Slur on after or way-after grace.  Use as signal to START slur.
c  25    Tweak orn ht. Same in icrdorn for chord note
c  26    Insert user-defined space before this note (was 22)
c  27    Arpeggio stop or start (if 2 at same time), or all-in-this-chord
c  28-31   Not used?
c
c   And now irest is also a set of switches
c
c  0        rest=1, no rest = 0
c  1        There will be a vertical shift for number of this xtup
c  2-6      Height shift, 1 => -15, 31 => +15  Indicate by +/- [n] after 'n'
c  7        There is a horizontal shift for xtup number
c  9-13     Horiz shift, 1=>-1.5, ... , 31=>+1.5
c  14       Flip up/down-ness of xtup number
c  15       Single-voice, single note shift  X(...)[p]S
c  16       Start single-voice, multinote shift with this note X(...)[p]:
c  17       End single-voice, multinote shift after this note. Enter symbol
c              after note. X:
c  18       User-defined hardspace after last note of bar, *after* this note.
c              Value still stored in udoff(ivx,nudoff(ivx)), not with other
c              hardspaces in udsp, to avoid confusion with time checks.
c  19       Move the dot.  Data stored in ndotmv,updot,rtdot
c  20       Set if right-shifted main or chord note here.  Use for space checks.
c  21       User-defined hardspace in xtup
c  22       User-defined slur shift horizontal slur shift.
c  23       Set on last note before staff-jumping a beam.
c  24       Set on first note after staff-jumping a beam
c  25       Suppress rest centering. "ro"
c  26       Dynamic on this note
c  27       Set if left-shifted main or chord note here.  Use for space checks.
c  28       Set if xtup starts on this note.
c  29       Set on lowest-voice note at same time as 1st note after jump-beam. 
c
c  nacc:  Accidental stuff
c
c  0-1      0=no accid, 1=fl, 2=sh, 3=na
c  2        double
c  3        big
c  4-9      vertshift-32
c  10-16    20*(horiz. shift + 3.2)
c
c  isdat1: Slur information
c
cc  0-2      iv
c  13-17    iv
c  3-10     ip
c  11       start/stop switch
c  12       kv-1
c  19-25    ichar(code$)
c  26       force direction?
c  27       forced dir'n = up if on, set in sslur; also
c           final direction, set in doslur when beam is started, used on term.
c  28-31    ndxslur, set in doslur when beam is started, used on term.
c
c  isdat2
c
c  0        Chord switch.  Not set on main note.
c  1-2      left/right notehead shift.  Set only for chord note.
c  3        tie positioning
c  4        dotted slur
c  6-11     voff1 1-63  =>  -31...+31
c  12-18    hoff1 1-127 => -6.3...+6.3
c  19-25    nolev
c
cccccccccccccccccccccccccccccccc
      character*65536 bufq
      integer*2 lbuf(2000)
      common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
      character*6 figq
      character*1 ulq,sepsymq,sq,chax
      logical beamon,firstgulp,figbass,figcheck,
     *        isfig,rptnd1,rptprev
      logical loop,lastchar,slint,svolta,evolta,onvolt,
     *        cwrest(nm),islast,inlast,optimize
      integer nsystp(30),istop(80),numbms(nm),istart(80)
      real*4 xnsttop(30),xintstaff(30),hesk(23),hpts(23),poevec(nks),
     *        tstart(80),squez(80)
      character*1  clefq(nm),ulfbq,rptfq1,rptfq2,charq
      character*79 notexq,inameq
      character*40 pathnameq
      character*24 basenameq,fmtq
      character*10 voltxtq
      character*60 instrq,titleq,compoq,cheadq
      common /comlast/ islast
      common /combjmp/ ivbjmp,isbjmp
      common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
     *    inhead
      common /cominbot/ inbothd
      common /comfig/ itfig(74),figq(74),nfigs
      common /comnsp/ space(80),nb,prevtn(nm),
     *    flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
      common /comstart/ facmtr
      common /comfb/ nfb(nm),t1fb(nm,20),t2fb(nm,20),ulfbq(nm,20),ifb
      common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,
     *       movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
     *       rptprev,rptfq1,rptfq2
      common /combeam/ ibmtyp
      common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd,
     *                npreslur,was2(nm),noinst,nobar1
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,idsig,
     *   lnam(nm),inameq(nm)
      common /comas1/ naskb,task(20),wask(20),elask(20)
      common /comas2/ nasksys,wasksys(400),elasksys(400)
      common /comas3/ ask(1400),iask,topmods
      common /comask/ bar1syst,fixednew,scaldold,
     *                wheadpt,fbar,poenom
      common /comslur/ listslur,upslur(nm,2),ndxslur
      common /comsln/ is1n1,is2n1,irzbnd,isnx
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),aftshft,
     *                nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
     *                noffseg,ngrace,nvolt,ivlit(52),iplit(52),nlit,
     *                lenlit(52),multg(37),upg(37),slurg(37),slashg(37),
     *                naccg(74),voltxtq(6),litq(52)
      logical upg,slurg,slashg,fbon,ornrpt,shifton,isbjmp,notcrd,was2
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      character*128 litq,lnholdq
      logical upslur,bar1syst,vshrink,lrpt,rrpt,lrptpend,
     *   ispoi,bcspec,topmods,headlog,clchb,clchv(nm),flgndb,
     *   btest,sluron,setis,nobar1
      common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
     *               ndotmv(nm),updot(nm,20),rtdot(nm,20)
      common /compoi/ ispoi
      common /combc/ bcspec
      common /comeon/ eonk,ewmxk
      common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
     *                flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
     *                rtshfac
      common /comhsp/ hpttot(176)
      common /combmh/ bmhgt,clefend
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtrans/ ntrans,cheadq
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
      common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
      common /comdyn/ ndyn,idyndat(99)
      common /commus/ musize,whead20
      common /comtol/ tol
      logical mrecord,mplay,endmac,flipend,istype0,lowdot,rename
      integer*2 mmidi
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
      if (.not.optimize) then
        print*
        print*,'Starting second PMX pass'
        print*
        write(15,'(a)')'Starting second PMX pass'
      end if
      ncalls = ncalls+1
      islast = inlast
      macuse = 0
      isyscnt = 0
      stemmax = 8.2
      stemmin = 3.9
      stemlen = 6.0
      sq = chax(92)
      bcspec = .true.
      topmods = .false.
      read(12,'(a)')basenameq
      read(12,*)lbase
      read(12,*)fbar,wheadpt,etait,etatc,etacs1,etatop,
     *         etabot,inbothd,inhnoh,isig
      ilbuf = 1
      ipbuf = 0
      call getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0,
     *            npages,nsyst,musicsize,fracindent,istype0,inameq,
     *            clefq,sepsymq,pathnameq,lpath,isig0)
      if (ismidi) then
c
c  Initial key signature and meter for pickup bar
c
        call midievent('k',isig,0)
        if (xmtrnum0 .gt. tol) then
c
c  We have a pickup.  Some tricky stuff to get a meter:
c
          xntrial = xmtrnum0
          do 5 ip2 = 0 , 5
            if (abs(mod(xntrial,1.)) .lt. tol) go to 6
            xntrial = xntrial*2
5         continue
          print*,'Problem finding meter for pickup bar'
          xntrial = 1.
          ip2 = 0          
6         continue
          call midievent('m',nint(xntrial),2**ip2*mtrdenl)
        else
c
c  No pickup, enter the starting meter
c
          call midievent('m',mtrnuml,mtrdenl)
        end if          
      end if
c
c  Set musicsize from value passed in common, due to possible reset by S[n]m16
c
      musicsize = musize
      read(12,*)npages,widthpt,height,nsyst,
     *   (nsystp(ipa),xnsttop(ipa),xintstaff(ipa),ipa=1,npages),iauto
c
c  If default width ever changes, must adjust this stmt.
c
      slfac1 = 0.00569*524./widthpt
      figbass = .false.
      read(13,*)ifig
      if (ifig .eq. 1) then
        figbass = .true.
        open(14,status='SCRATCH')
        write(14,'(a)')sq//'def'//sq//'fixdrop{'//sq//'advance'//sq//
     *      'sysno by 1'//sq//'ifcase'//sq//'sysno%'
      end if
      lastchar = .false.
      ibcoff = 0
      if (xmtrnum0 .gt. 0.) ibcoff = -1
      open(11,status='SCRATCH')
      call topfile(basenameq,lbase,nv,clefq,noinst,musicsize,
     *      xintstaff(1),mtrnmp,mtrdnp,vshrink,fbar)
c
c  ninow is working value of # of instruments.  noinst is max #, and # at start.
c
      ninow = noinst
c
c  Save original printed meter in case movement breaks
c
      movnmp = mtrnmp
      movdnp = mtrdnp
c
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 (islast .and.
     *   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 = nint(xmtrnum0*lenbeat)
      if (mtrdenl .eq. 2) lenb0 = lenb0*2
      if (lenb0 .ne. 0) then
        if (islast) write(11,'(a)')sq//'advance'//sq//'barno by -1'
        lenbar = lenb0
      else
        lenbar = lenb1
      end if
c
c  Initialize full-program variables
c
      fixednew = 0.
      scaldold = 0.
      fintstf = -1.
      gintstf = 1.
      nasksys = 0
      ibarcnt = 0
      iline = 0
      movbrk = 0
      isystpg = 0
      ipage = 1
      iccount = 128
      iask = 0
      nhstot = 0
      nb = 1
      if (.not.optimize) jprntb = 81
      idsig = 0
c
c  Next 5 are raise-barno parameters.  irzbnd is integer part of default level.
c
      irzbnd = 3
      if (isig.eq.3 .and. clefq(nv).eq.'t') irzbnd = 4
      is1n1 = 0
      isnx = 0
      ispoi = .false.
      slint = .false.
      lrptpend = .false.
      rptnd1 = .false.
      rptfq2 = 'E'
      rptprev = .false.
      onvolt = .false.
      flgndb = .false.
      fbon = .false.
      shifton = .false.
      ornrpt = .false.
      setis = .false.
c      notcrd = .true.
      lowdot = .false.
      rename = .false.
      nobar1 = .false.
c
c  ixrest = 1 or 2 if xtup has started with a rest
c
      do 1 ivx = 1 , nm
        ixrest(ivx) = 0
1     continue
      npreslur = 0
      nhssys = 0
      listslur = 0
      do 31 i = 1 , 101
        isdat1(i) = 0
        isdat2(i) = 0
31    continue
      nsdat = 0
c
c  Initialize for loop over gulps
c
      firstgulp = .true.
c
c  Start a gulp
c
30    loop = .true.
      notcrd = .true.
      nbars = 0
      nfigs = 0
      ngrace = 0
      ntrill = 0
      ncrd = 0
      nudorn = 0
      nlit = 0
      nvolt = 0
      ibarmbr = 0
      nudsp = 0
      ndyn = 0
c
c  Now initialize up to nv.  Do it in getnote as r'qd for 2nd voices per syst.
c  and also if nv increases in an 'M' directive.
c
      do 4 iv = 1 , nv
        call newvoice(iv,clefq(iv),.false.)
4     continue
c
c  Check if endsymbol was set earlier
c
      if (rptnd1) then
        rptnd1 = .false.
        rptfq2 = rptfq1
      else
c
c  Only use if movbrk>0, to signal default ('RD')
c
        rptfq2 = 'E'
      end if
      iv = 1
      ivx = 1
2     if (loop) then
c
c  Within this loop, nv voices are filled up for the duration of the block.
c  On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv)
c  nolev(nv,nnl(nv)),nodur(..),accq(..),irest(..).
c  nbars is for this input block.
c  Only at the beginning of an input block will there be a possible mtr change,
c  signalled by a nonzero mtrnuml. (which will be re-zeroed right after change)
c
        call getnote(loop)
        if (lastchar) go to 40
        go to 2
      end if
c
c  Finished an input block (gulp).
c
      if (ismidi) then
c
c  Put rests into midi array for 2nd lines that were not used in this gulp.
c
        do 60 iv = 1 , nv
          if (twoline(iv) .and. nvmx(iv).eq.1) then
            if (firstgulp .and. lenb0.ne.0) then
              call addmidi(midchan(iv,2),0,0,0,
     *                   (nbars-1.)*lenbar+lenb0,.true.,.false.)
            else
              call addmidi(midchan(iv,2),0,0,0,1.*nbars*lenbar,.true.,
     *                     .false.)
            end if
          end if
60      continue
      end if
      nvolt = 0
      do 28 iv = 1 , nm
        nudoff(iv) = 0
        ndotmv(iv) = 0
28    continue
c
c  Put 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
        ndig = max(0,int(log10(.001+ibarcnt+ibcoff)))
      if (islast)
     *  write(11,'(a11,i'//chax(50+ndig)//')')
     *              '% Bar count',ibarcnt+ibcoff
        if (ibar .ne. ibarmbr) then
          if (.not.optimize) call outbar(ibarcnt+ibcoff,jprntb)
        else
          if (.not.optimize) then
            write(*,'(/,a19,i4,a1,i4)')' Multibar rest, bars',
     *         ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1
            write(15,'(/,a19,i4,a1,i4)')' Multibar rest, bars',
     *         ibarcnt+ibcoff,'-',ibarcnt+ibcoff+mbrest-1
            jprntb = 0
          end if
          ibcoff = ibcoff+mbrest-1
          if (ibar.eq.1 .and. firstgulp) xb4mbr = facmtr*musicsize
        end if
c
c  Move the read to after end-of-bar hardspace checks, so we get right poenom
c  at end of a line.
c       if (bar1syst) read(12,*) poenom
c
c  Check for clef at start of bar.  No slide yet.  Also flags at end of prev.
c  bar.  This block is run at the start of every bar.  May fail for flag at
c  end of last bar.  To account for necc. hardspaces, compute and store
c    nhssys = # of hard spaces for this system
c    hesk(nhssys) = elemskips avialable
c    hpts(nhssys) = hard points needed, including notehead
c  Here, merely insert placeholder into output.  Later, when poe is computed,
c  compute additional pts and store them in hpttot(1...nhstot).  Finally in
c  subroutine askfig, write true pts where placeholders are.
c
        ioff = 0
        if (ibar .gt. 1) ioff = nib(1,ibar-1)
        clchb = btest(islur(1,ioff+1),15)
        if (.not.(clchb .or. flgndb)) go to 23
c
c  Must check available space
c
        ptsndb = 0.
c
c  Zero out block signal
c
        if (clchb) islur(1,ioff+1) = ibclr(islur(1,ioff+1),15)
c
c  In this loop, we determine how much hardspace is needed (if any)
c  9/7/97  Note that for last bar in input block, if number of lines of
c    music decreases in new block, highest numbered ones won't be checked
c    since the loop below covers the new nvmx(iv), not necessarily the old
c    one.
c  4/18/98 Apparently nmxsav was a solution to the above problem
c
        do 16 iv = 1 , nv
        do 16 kv = 1 , nvmxsav(iv)
          ivx = ivmxsav(iv,kv)
          ptsndv = flgndv(ivx)*wheadpt
          ioff = 0
          if (ibar .gt. 1) then
            ioff = nib(ivx,ibar-1)
            ip = ioff
            if (ibar.gt.2) ip = ioff-nib(ivx,ibar-2)
            prevtn(ivx) = tnote(iand(ipl(ivx,ip),255))
c
c If ibar=1 (1st bar in input block), prevtn(ivx) was set at end of makeabar.
c
          end if
c
c  Only allow clef changes when ivx <= nv
c
          if (ivx .le. nv) then
            clchv(iv) = clchb .and. btest(islur(iv,ioff+1),11)
            if (clchv(iv)) then
c
c  Clef change in this voice.  Turn off signal.  Get space avail.
c
              islur(iv,ioff+1) = ibclr(islur(iv,ioff+1),11)
              if (abs(prevtn(iv)-space(nb)).lt.tol) ptsndv =
     *             ptsndv+clefend*wheadpt
            end if
          end if
          ptsndb = max(ptsndb,ptsndv+wheadpt*xspfac)
16      continue
c
c ????  where is nb set???  nb probably in left over from makeabar
c
        esk = feon(space(nb)*squez(nb))
        ptsdflt = esk*poenom-wheadpt
        if ((ptsndb.gt.ptsdflt.or.ptsgnd.gt.0.) .and. movbrk.eq.0) then
c
c  Must ADD hardspace!  So put in a placeholder, and store params for later.
c
          if (islast) write(11,'(a)')sq//'xardspace{    pt}%'
          nhssys = nhssys+1
          if (ptsndb-ptsdflt .gt. ptsgnd-poenom*eskgnd) then
            hesk(nhssys) = esk
            hpts(nhssys) = ptsndb+wheadpt
          else
            hesk(nhssys) = eskgnd
            hpts(nhssys) = ptsgnd+wheadpt
          end if
          fixednew = fixednew+hpts(nhssys)
          scaldold = scaldold+hesk(nhssys)
        end if
        if (clchb) then
          do 17 iv = 1 , nv
            if (clchv(iv)) then
              notexq = sq//'znotes'
              lnote = 7
              do 24 iiv = 2 , iv
                notexq = notexq(1:lnote)//sepsymq(iiv-1)
                lnote = lnote+1
24            continue
c
c  Recompute ioff since it will vary from voice to voice
c
              if (ibar .eq. 1) then
                ioff = 0
              else
                ioff = nib(iv,ibar-1)
              end if
c
c  Must call clefsym to get nclef, even if there is a movement break
c
              call clefsym(islur(iv,ioff+1),fmtq,lclef,nclef)
              if (movbrk.eq.0 .and.
     *            islast)
     *          write(11,'(a)')notexq(1:lnote)//fmtq(1:lclef)//sq//'en%'
              call wsclef(iv,ninow,clefq,nclef)
            end if
17        continue
          if (islast) write(11,'(a)')sq//'pmxnewclefs'
        end if
23      continue
c
c  End of loop for end-of-bar hardspaces and non-movbrk clef symbol.
c
        if (bar1syst) then
          read(12,*) poenom
        end if
c
c  Repeat symbols.  Haven't slid down yet, so use islur(1,nib(1,ibar-1)+1)
c
        if (ibar .eq. 1) then
          islnow = islur(1,1)
        else
          islnow = islur(1,nib(1,ibar-1)+1)
        end if
c
c  Check for R-symbols set at end of prior input block
c
        if (movbrk.eq.0 .and. rptfq2.ne.'E') then
          if (rptfq2 .eq. 'D') then
            islnow = ibset(islnow,26)
          else if (rptfq2 .eq. 'r') then
            islnow = ibset(islnow,6)
          else if (rptfq2 .eq. 'd') then
            islnow = ibset(islnow,8)
          else if (rptfq2 .eq. 'b') then
            islnow = ibset(islnow,25)
          else
            print*
            print*,'Illegal symbol with "R" at end of input block:',
     *        rptfq2
            stop 1
          end if
          rptfq2 = 'E'
        end if
        if (iand(islnow,352) .ne. 0) then
c
c  Bit 5(lrpt), 6(rrpt), or 8(doublebar) has been set
c
          lrpt = btest(islnow,5)
          rrpt = btest(islnow,6)
          lrptpend = lrpt.and.bar1syst
          if (lrpt .and. .not.lrptpend) then
            if (rrpt) then
              if (islast) write(11,'(a)')sq//'setleftrightrepeat'
              fixednew = fixednew+wheadpt*lrrptfac-0.4
            else
              if (islast) write(11,'(a)')sq//'setleftrepeat'
              fixednew = fixednew+wheadpt*rptfac-0.4
            end if
          else if (rrpt) then
            if (islast) write(11,'(a)')sq//'setrightrepeat'
            fixednew = fixednew+wheadpt*rptfac-0.4
          else if (btest(islnow,8)) then
            if (islast) write(11,'(a)')sq//'setdoublebar'
            fixednew = fixednew+wheadpt*dbarfac-0.4
          end if
        else if (btest(islnow,26)) then
c
c  doubleBAR
c
          if (islast) write(11,'(a)')sq//'setdoubleBAR'
          fixednew = fixednew+wheadpt*ddbarfac-0.4
        end if
c
c  1st and 2nd endings
c
        svolta = btest(islnow,7)
        evolta = btest(islnow,9)
        if (evolta) then
          if (btest(islnow,10)) then
            if (islast) write(11,'(a)')sq//'endvoltabox'
          else
            if (islast) write(11,'(a)')sq//'endvolta'
          end if
          onvolt = .false.
        end if
        if (svolta) then
          nvolt = nvolt+1
          lvoltxt = index(voltxtq(nvolt),' ')-1
          if (lvoltxt .eq. 1) then
            if (islast) write(11,'(a)')sq//'Setvolta'
     *          //voltxtq(nvolt)(1:1)//'%'
          else
            if (islast) write(11,'(a)')sq//'Setvolta'//'{'//
     *        voltxtq(nvolt)(1:lvoltxt)//'}%'
          end if
          onvolt = .true.
        end if
        if (ibar .gt. 1) then
          ipnow = nib(1,ibar-1)+1
        else
          ipnow = 1
        end if
        iplnow = ipl(1,ipnow)
        if (bar1syst) then
          iline = iline+1
c
c  End an old system, Start a new system
c
          if (iline .ne. 1) then
c
c  Not first line.
c  Get corrected poe = points/elemskip for *previous* system
c
            wdpt = widthpt*(1-fracindent)
            poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/
     *            (elsktot+fbar*nbarss-scaldold)
            isyscnt = isyscnt+1
            poevec(isyscnt) = poe
c
c  Transfer data for system into global arrays to hold until very end
c
            do 9 ia = 1 , nasksys
              iask = iask+1
              ask(iask) = wasksys(ia)/poe-abs(elasksys(ia))
c
c  Only admit negative ask if it was user-defined space, signalled by elask<=0.
c
              if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.)
9           continue
            do 25 ia = 1 , nhssys
              nhstot = nhstot+1
              hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.)
25          continue
c
c  Reset counters for new system
c
            scaldold = 0.
            fixednew = 0.
            nasksys = 0
            nhssys = 0
          end if
c
c  End of if block for first bar of non-first system. Still 1st bar, any system
c
          if (islast.and.figbass) write(11,'(a)')sq//'fixdrop%'
          isystpg = isystpg+1
          if (isystpg .eq. nsystp(ipage)) isystpg = 0
          read(12,*)nbarss,elsktot,fsyst,frac,eonk,ewmxk
          if (iline .gt. 1) fracindent=frac
          if (figbass) ifigdrop(iline) = 4
          slfac = slfac1*musicsize*elsktot
          if (iline .ne. 1) then
c
c  For the line just _finished_, put figdrop in separate file.
c
            if (figbass) write(14,'(a9,i2,a10)')
     *          sq//'figdrop=',ifigdrop(iline-1),sq//'or%'
c
c  Check slurs in top staff for interference w/ barno. Only check when
c  # if digits in barno >= |isig|  But to keep on/off phasing, must ALWAYS
c  keep track of ons and offs when |isig|<=3.
c
            ndigbn = int(alog10(ibarcnt+ibcoff+.01))+1
            isnx = 0
            if (ndigbn.ge.iabs(isig) .and. is1n1.gt.0) then
c
c  There's a slur in top voice over the line break, hgt=is1n1, idcode=is2n1
c  Look for termination in remainder of this input block.  If not found,
c  just use is1n1.  Remember, haven't slid down yet.
c
              ioff = 0
              if (ibar .gt. 1) ioff = nib(ivmx(nv,nvmx(nv)),ibar-1)
              do 50 isdat = 1 , nsdat
c                if (igetbits(isdat1(isdat),3,0).eq.ivmx(nv,nvmx(nv))
                if (igetbits(isdat1(isdat),5,13).eq.ivmx(nv,nvmx(nv))
     *              .and. .not.btest(isdat1(isdat),11)
     *              .and. igetbits(isdat1(isdat),7,19).eq.is2n1) then
c
c  Found slur ending.  Just check note height, can't do fine adjustments.
c
                  is1n1 = max(is1n1,igetbits(isdat2(nsdat),7,19))
                  go to 51
                end if
50            continue
c
c  If exiting loop normally, did not find end of slur.  c'est la vie.
c
51            continue
              isnx = idim(is1n1,ncmid(nv,1)+1+irzbnd)
              if (isnx .gt. 0) then
c
c  AHA! Slur likely to interfere with barno.
c
                slint = .true.
                fmtq = '(a16,i1,a14)'
                if (irzbnd+isnx .gt. 9) fmtq = '(a16,i2,a14)'
                if (islast) write(11,fmtq)sq//'def'//sq//'raisebarno{',
     *             irzbnd+isnx,'.5'//sq//'internote}%'
              end if
            end if
            if (movbrk .gt. 0) then
c
c              movbrk = 0
c  Move the reset down, so can use movbrk>0 to stop extra meter prints.
c
c  New movement.  Redefine stoppiece, contpiece.  These will be called either
c     explicitly or as part of alaligne.
c  indsym = 0,1,2 for doubleBAR , doublebar, rightrepeat.
c     This is passed to \newmovement.
c
              if (rptfq2 .eq. 'E') rptfq2 = 'D'
              indsym = index('Ddrb',rptfq2)-1
              rptfq2 = 'E'
c
c  Also check for Rd or Rr set the normal way
c
              if (btest(islnow,8)) then
                indsym = 1
              else if (btest(islnow,6)) then
                indsym = 2
              end if
              if (indsym .lt. 0) then
                print*
                print*,'Illegal end symbol before "/"'
                stop 1
              end if
c
c  Check for continuation (no bar number reset)
c
              if (islast.and.
     *            nobar1) write(11,'(a)')sq//'advance'//sq//'barno1'
     *           //sq//'startbarno'//sq//'barno%'
              if (movgap .lt. 10) then
                if (islast) write(11,'(a12,2i1,a1)')
     *                sq//'newmovement',movgap,indsym,'%'
              else
                if (islast) write(11,'(a13,i2,a1,i1,a1)')
     *                sq//'newmovement{',movgap,'}',indsym,'%'
              end if
c
c  Change generalmeter if necessary
c
              if (islast) call wgmeter(mtrnmp,mtrdnp)
c
c  (Moved all name-writing to getnote, right when 'M' is detected)
c
              if (btest(iplnow,28)) then
c
c  Key signature at movement break
c
                iplnow = ibclr(iplnow,28)
                if (isig .gt. 0) then
                  if (islast) write(11,'(a18,i1,a2)')
     *                sq//'generalsignature{',isig,'}%'
                else
                  if (islast) write(11,'(a18,i2,a2)')
     *                sq//'generalsignature{',isig,'}%'
                end if
              end if
              if (parmov .ge. -.1) then
c
c  Resent paragraph indentation
c
                ipi = parmov*widthpt+.1
                if (ipi .lt. 10) then
                  if (islast) write(11,'(a11,i1,a2)')
     *                sq//'parindent ',ipi,'pt'
                else if (ipi .lt. 100) then
                  if (islast)
     *              write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt'
                else
                  if (islast)
     *              write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt'
                end if
              end if
            end if
            if (isystpg .eq. 1) then
c
c  First line on a page (not 1st page, still first bar).  Tidy up old page
c  then eject.
c
              if (onvolt) then
                if (islast) write(11,'(a)')sq//'endvoltabox%'
                onvolt = .false.
              end if
c
c  Check for meter change at start of a new PAGE
c
              if (mtrnuml .gt. 0) then
c
c  Meter change at start of a new page.  Ugly repeated coding here.
c
                mtrnms = mtrnuml
                call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
                mtrnuml = mtrnms
                if (movbrk .eq. 0 .and. islast) 
     *              call wgmeter(mtrnmp,mtrdnp)
              end if
c
c  Key signature change?
c
              if (btest(iplnow,28) .and. movbrk.eq.0) then
                notexq = sq//'xbar'//sq//'addspace{-'//sq//
     *            'afterruleskip}'//sq//'generalsignature{'
                lnote = 49
                if (isig .lt. 0) then
                  notexq = notexq(1:49)//'-'
                  lnote = 50
                end if
                if (islast) write(11,'(a)')
     *              notexq(1:lnote)//chax(48+abs(isig))//'}%'
                if (islast) write(11,'(a)')sq//'zchangecontext'//sq
     *              //'addspace{-'//sq//'afterruleskip}'//sq//'def'
     *              //sq//'writezbarno{}'//sq//'zstoppiece%'
              else if (mtrnuml.gt.0 .and. movbrk.eq.0) then
c
c  Meter change but no signatuire change
c
                if (islast)
     *          write(11,'(a)')sq//'xchangecontext'//sq//'addspace{-'//
     *              sq//'afterruleskip}'//sq//'let'//sq//'bnat'//sq//
     *              'barnoadd%'
                if (islast)
     *          write(11,'(a)')sq//'def'//sq//'barnoadd{'//sq//'let'//
     *              sq//'barnoadd'//sq//'bnat}'//sq//'zstoppiece%'
              else
                if (islast) write(11,'(a)')sq//'stoppiece%'
              end if
              if (.not.vshrink) then
                xnstbot = xnsttop(ipage)*etabot/etatop
                if (xnstbot .lt. 9.95) then
                  fmtq = '(a,f3.1,a)'
                else
                  fmtq = '(a,f4.1,a)'
                end if
                if (islast) write(11,fmtq)sq//'vskip',xnstbot,
     *              sq//'Interligne'//sq//'eject%'
              else
                if (islast) write(11,'(a)') sq//'vfill'//sq//'eject%'
              end if
              ipage = ipage+1
              vshrink = xintstaff(ipage) .gt. 20
              if (vshrink) then
                xinsnow = 10
              else
                xinsnow = xintstaff(ipage)
              end if
              if (fintstf.gt.0 .and. ipage.gt.1) then
                xinsnow = xinsnow*fintstf/gintstf
                fintstf = -1.
              end if
              if (xinsnow .lt. 9.95) then
                fmtq = '(a,f3.1,a)'
              else if (xinsnow .lt. 99.95) then
                fmtq = '(a,f4.1,a)'
              else
                fmtq = '(a,f5.1,a)'
              end if
c
c  Vertical spacing parameters, then restart
c
              if (islast) write(11,fmtq)sq//'interstaff{',xinsnow,
     *            '}'//sq//'contpiece'
c
c  Check for meter change at start of a new PAGE
c
              if (mtrnuml .gt. 0) then
c
c  Meter change at start of a new page
c
                call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
                if (movbrk .eq. 0) then
                  if (islast) call wgmeter(mtrnmp,mtrdnp)
                  if (mtrdnp .gt. 0) then
                    if (islast) write(11,'(a)')sq//'newtimes2%'
                    if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize
                  end if
                end if
              end if
c
c  If no real titles here, which there probably will never be, make vertical
c  space at page top with \titles{...}.  headlog=.false.<=>no real titles
c
              call puttitle(inhnoh,xnsttop(ipage),etatop,
     *           sq,etait,etatc,etacs1,nv,vshrink,sepsymq)
            else
c
c  First bar of system, not a new page, force line break
c
              if (btest(iplnow,28)) then
c
c  Signature change
c
                notexq = sq//'xbar'//sq//'addspace{-'//sq//
     *            'afterruleskip}'//sq//'generalsignature{'
                lnote = 49
                if (isig .lt. 0) then
                  notexq = notexq(1:49)//'-'
                  lnote = 50
                end if
                if (islast) write(11,'(a)')notexq(1:lnote)
     *                   //chax(48+abs(isig))//'}%'
                if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%'
                if (mtrnuml .ne. 0) then
c
c  Meter+sig change, new line, may need mods if movement break here.
c
                  call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
                  if (islast) then
                    call wgmeter(mtrnmp,mtrdnp)
                    write(11,'(a)')sq//'xchangecontext'//sq//
     *                'addspace{-'//sq//'afterruleskip}'//sq//'def'
     *                //sq//'writezbarno{}'//sq//'zalaligne%'
                    write(11,'(a)')sq//'addspace{-'//sq
     *                //'afterruleskip}%'
                    call wgmeter(mtrnmp,mtrdnp)
                    write(11,'(a)')sq//'zchangecontext'
                  end if
                else
                 if (islast) write(11,'(a)')sq//'xchangecontext'//sq//
     *               'addspace{-'//sq//'afterruleskip}'//sq//'def'//
     *               sq//'writezbarno{}'//sq//'zalaligne%'
                end if
              else if (mtrnuml .eq. 0) then
c
c  No meter change
c
                if (islast) write(11,'(a)')sq//'alaligne'
              else
c
c  New meter, no new sig, end of line, not new page.
c
c \generalmeter{\meterfrac{3}{4}}%
c \xchangecontext\addspace{-\afterruleskip}%
c \zalaligne\generalmeter{\meterfrac{3}{4}}\addspace{-\afterruleskip}%
c \zchangecontext
c
                call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
                if (movbrk .eq. 0) then
                  if (islast) call wgmeter(mtrnmp,mtrdnp)
                  if (mtrdnp .gt. 0) then
                    if (islast) then
                      write(11,'(a)')
     *                    sq//'let'//sq//'bnat'//sq//'barnoadd'
     *                    //sq//'def'//sq//'barnoadd{'//sq//'empty}%'
                      write(11,'(a)')sq//'xchangecontext'//sq//
     *                   'addspace{-'//sq//'afterruleskip}'//sq//
     *                'zalaligne'//sq//'let'//sq//'barnoadd'//sq//'bnat'
                      call wgmeter(mtrnmp,mtrdnp)
                      write(11,'(a)')sq//'addspace{-'//sq//
     *                   'afterruleskip}'//sq//'zchangecontext'
                    end if
                    if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize
                  else
                    if (islast) write(11,'(a)')sq//'alaligne'
                  end if
                else
                  if (islast) write(11,'(a)')sq//'alaligne'
                end if
              end if
            end if
            if (slint) then
              slint = .false.
              if (islast) write(11,'(a16,i1,a14)')sq//'def'//sq//
     *              'raisebarno{',irzbnd,'.5'//sq//'internote}%'
            end if
            movbrk = 0
          end if
c
c  Clean up if we squelched bar number reset at movement break
c
          if (nobar1) then
            if (islast) write(11,'(a)')sq//'startbarno1'
            nobar1 = .false.
          end if
          read(12,*,end=14)iauto
14        continue
c
c  We come thru here for the 1st bar of every system, so initialize is1n1
c
          is1n1 = 0
        else
c
c  Not first bar of system
c
          if (btest(iplnow,28)) then
c
c  Signature change
c
            if (mtrnuml .ne. 0) then
c
c  Meter+signature change mid line, assume no movement break
c
              call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
              if (islast) call wgmeter(mtrnmp,mtrdnp)
              notexq = sq//'generalsignature{'
              lnote = 18
              if (isig .lt. 0) then
                notexq = notexq(1:18)//'-'
                lnote = 19
              end if
              if (islast) then
                iptemp = 48+abs(isig)
                charq = chax(iptemp)
                notexq = notexq(1:lnote)//charq//'}'
     *                   //sq//'xchangecontext%'
                write(11,'(a)')notexq(1:lnote+18)
              end if
            else
c
c  Signature change only
c
              notexq = sq//'xbar'//sq//'addspace{-'//sq//
     *            'afterruleskip}'//sq//'generalsignature{'
              lnote = 49
              if (isig .lt. 0) then
                notexq = notexq(1:49)//'-'
                lnote = 50
              end if
              if (islast)
     *          write(11,'(a)')notexq(1:lnote)//chax(48+abs(isig))//'}%'
              if (islast) write(11,'(a)')sq//'zchangecontext'//sq
     *            //'addspace{-.5'// sq//'afterruleskip}%'
            end if
          else if (mtrnuml .eq. 0) then
c
c  No meter change
c
            if (islast) write(11,'(a)')sq//'xbar'
          else
c
c  Change meter midline
c
            call setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
            if (movbrk .eq. 0) then
              if (islast) call wgmeter(mtrnmp,mtrdnp)
              if (mtrdnp .gt. 0) then
                if (islast) write(11,'(a,2i1,a)')sq//'newtimes0%'
                if (ibar .eq. ibarmbr) xb4mbr = facmtr*musicsize
              else
                if (islast) write(11,'(a)')sq//'xbar'
              end if
            end if
          end if
        end if
c
c  Now that xbar's are written, can put in left-repeats at line beginnings
c
        if (lrptpend) then
          if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1'
     *        //sq//'leftrepeat'
          lrptpend = .false.
        end if
        if (ibar .gt. 1) then
c
c  For bars after first, slide all stuff down to beginning of arrays
c
          do 11 iv = 1 , nv
          do 11 kv = 1 , nvmx(iv)
            ivx = ivmx(iv,kv)
            ioff = nib(ivx,ibar-1)
            do 12 ip = 1 , nib(ivx,ibar)-ioff
              nolev(ivx,ip) = nolev(ivx,ip+ioff)
              nodur(ivx,ip) = nodur(ivx,ip+ioff)
              nacc(ivx,ip) = nacc(ivx,ip+ioff)
              irest(ivx,ip) = irest(ivx,ip+ioff)
              islur(ivx,ip) = islur(ivx,ip+ioff)
              ipl(ivx,ip) = ipl(ivx,ip+ioff)
              iornq(ivx,ip) = iornq(ivx,ip+ioff)
              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 (tcc(iv,icc) .le. lenbar) then
c
c  This time will drop <=0 when slid.
c
                  islide = icc-1
                  ncmidcc(iv,1) = ncmidcc(iv,icc)
                else
                  tcc(iv,icc-islide) = tcc(iv,icc)-lenbar
                  ncmidcc(iv,icc-islide) = ncmidcc(iv,icc)
                end if
13            continue
              ncc(iv) = ncc(iv)-islide
              tcc(iv,1) = 0.
            end if
11        continue
          do 15 ig = 1 , ngrace
            ipg(ig) = ipg(ig)-nib(ivg(ig),ibar-1)
            if (ibar .gt. 2) ipg(ig) = ipg(ig)+nib(ivg(ig),ibar-2)
15        continue
          do 21 il = 1 , nlit
            iplit(il) = iplit(il)-nib(ivlit(il),ibar-1)
            if (ibar .gt. 2) iplit(il) = iplit(il)+nib(ivlit(il),ibar-2)
21        continue
          do 22 it = 1 , ntrill
            iptrill(it) = iptrill(it)-nib(ivtrill(it),ibar-1)
            if (ibar .gt. 2) iptrill(it) =
     *                    iptrill(it)+nib(ivtrill(it),ibar-2)
22        continue
          do 27 icrd = 1 , ncrd
            ivx = iand(15,ishft(icrdat(icrd),-8))
            ipnew = iand(255,icrdat(icrd))-nib(ivx,ibar-1)
            if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2)
            icrdat(icrd) = iand(not(255),icrdat(icrd))
            icrdat(icrd) = ior(max(0,ipnew),icrdat(icrd))
27        continue
          do 29 iudorn = 1 , nudorn
            ivx = iand(15,ishft(kudorn(iudorn),-8))
            ipnew = iand(255,kudorn(iudorn))-nib(ivx,ibar-1)
            if (ibar .gt. 2) ipnew = ipnew+nib(ivx,ibar-2)
            kudorn(iudorn) = iand(not(255),kudorn(iudorn))
            kudorn(iudorn) = ior(max(0,ipnew),kudorn(iudorn))
29        continue
          do 42 idyn = 1 , ndyn
            idynd = idyndat(idyn)
            ivx = iand(15,idynd)
            ipnew = igetbits(idynd,8,4)-nib(ivx,ibar-1)
            if (ibar .gt. 2) then
              ipnew = ipnew+nib(ivx,ibar-2)
            end if
            ipnew = dim(ipnew,0)
            call setbits(idynd,8,4,ipnew)
            idyndat(idyn) = idynd
42        continue
          do 41 isdat = 1 , nsdat
            isdata = isdat1(isdat)
            ivx = ivmx(igetbits(isdata,5,13),igetbits(isdata,1,12)+1)
            ipnew = igetbits(isdata,8,3)-nib(ivx,ibar-1)
            if (ibar .gt. 2) then
              ipnew = ipnew+nib(ivx,ibar-2)
            end if
            ipnew = dim(ipnew,0)
            call setbits(isdata,8,3,ipnew)
            isdat1(isdat) = isdata
41        continue
c
c  Bookkeeping for figures.  This will set nfigs = 0 if there are no figs left.
c  If there are figs left, it will reset all times relative to start of
c  current bar.
c
          if (figbass) then
            islide = 0
            do 20 jfig = 1 , nfigs
              if (itfig(jfig) .lt. lenbar) then
c
c  This figure was already used
c
                islide = jfig
              else
                itfig(jfig-islide) = itfig(jfig)-lenbar
                figq(jfig-islide) = figq(jfig)
                itoff(jfig-islide) = itoff(jfig)
              end if
20          continue
            nfigs = nfigs-islide
          end if
        end if
c
c  The following may not be needed by makeabar, but just in case...
c
        if (firstgulp .and. lenb0.ne.0) then
          if (ibar .eq. 1) then
            lenbar = lenb0
          else
            lenbar = lenb1
          end if
        end if
        call make1bar(ibmrep,tglp1,tstart,cwrest,squez,
     *      istop,numbms,istart)
        call make2bar(ninow,tglp1,tstart,cwrest,squez,
     *      istop,numbms,istart,clefq)
c
c  Hardspace before barline?
c
        hardb4 = 0.
        do 35 iv = 1 , nv
        do 35 kv = 1 , nvmx(iv)
          ivx = ivmx(iv,kv)
          if (btest(irest(ivx,nn(ivx)),18)) then
            nudoff(ivx) = nudoff(ivx)+1
            hardb4 = max(hardb4,udoff(ivx,nudoff(ivx)))
          end if
35      continue
        if (hardb4 .gt. 0.) then
          if (islast) write(11,'(a11,f5.1,a4)')sq
     *        //'hardspace{',hardb4,'pt}%'
          fixednew = fixednew-hardb4
        end if
10    continue
      firstgulp = .false.
      lenb0 = 0
      go to 30
40    close(12)
      close(13)
      ilbuf = 1
      ipbuf = 0
      wdpt = widthpt
      if (iline .eq. 1) wdpt = widthpt*(1-fracindent)
      poe = (wdpt-fsyst*musicsize-0.4*nbarss-fixednew)/
     *            (elsktot+fbar*nbarss-scaldold)
      poevec(nsyst) = poe
      if (.not.islast) then
        close(11)
        close(16)
        if (figbass) close(14)
        return
      end if
      do 19 ia = 1 , nasksys
        iask = iask+1
        ask(iask) = wasksys(ia)/poe-abs(elasksys(ia))
        if (elasksys(ia).gt.0) ask(iask)=dim(ask(iask),0.)
19    continue
      do 26 ia = 1 , nhssys
        nhstot = nhstot+1
        hpttot(nhstot) = max(hpts(ia)-hesk(ia)*poe,0.)
26    continue
      if (islast .and.
     *    onvolt) write(11,'(a)')sq//'endvoltabox'
      if (rptfq2 .ne. 'E') then
c
c Terminal repeat.  Right or double?
c
        if (rptfq2 .eq. 'r') then
          if (islast) write(11,'(a)')sq//'setrightrepeat'
     *       //sq//'endpiece'
        else if (rptfq2 .eq. 'd') then
          if (islast) write(11,'(a)')sq//'setdoublebar'//sq//'endpiece'
        else if (rptfq2 .eq. 'b') then
          if (islast) write(11,'(a)')sq//'endpiece'
        else
          print*,'R? , ? not "d","r",or"b"; rptfq2:',rptfq2
          if (islast) write(11,'(a)')sq//'Endpiece'
        end if
      else
        if (islast) write(11,'(a)')sq//'Endpiece'
      end if
      if (.not.vshrink) then
        xnstbot = xnsttop(ipage)*etabot/etatop
        if (xnstbot .lt. 9.95) then
          fmtq = '(a,f3.1,a)'
        else
          fmtq = '(a,f4.1,a)'
        end if
        if (islast) write(11,fmtq)sq//'vskip',xnstbot,
     *      sq//'Interligne'//sq//'eject'//sq//'endmuflex'
        if (islast) write(11,'(a)')sq//'bye'
      else
        if (islast) write(11,'(a)')
     *     sq//'vfill'//sq//'eject'//sq//'endmuflex'
        if (islast) write(11,'(a)')sq//'bye'
      end if
      rewind(11)
      if (figbass) then
        write(14,'(a9,i2,a10)')sq//'figdrop=',ifigdrop(iline),sq//'fi}%'
        rewind(14)
      end if
      call askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0)
      if (.not.optimize) then
        print*
        print*,'Writing '
     *            //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex'
        print*,'Done with second PMX pass.'
        write(15,'(/,a)')'Writing '
     *            //pathnameq(1:lpath)//basenameq(1:lbase)//'.tex'
        write(15,'(a)')' Done with second PMX pass.  Now run TeX'
      end if
      return
      end
      subroutine make2bar(ninow,tglp1,tstart,cwrest,squez,
     *    istop,numbms,istart,clefq)
      parameter (nm=12,mv=24576)
      common /comlast/ islast
      logical islast
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      character*6 figq
      character*1 ulq,sepsymq,sq,chax
      logical beamon,firstgulp,figbass,figcheck,isfig,bar1syst,isbjmp
      common /combjmp/ ivbjmp,isbjmp
      common /comfig/ itfig(74),figq(74),nfigs
      common /combeam/ ibmtyp
      common /comask/ bar1syst,fixednew,scaldold,
     *                wheadpt,fbar,poenom
      common /comas1/ naskb,task(20),wask(20),elask(20)
      common /comas2/ nasksys,wasksys(400),elasksys(400)
      common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
      common /comfb/ nfb(nm),t1fb(nm,20),t2fb(nm,20),ulfbq(nm,20),ifb
      common /comsln/ is1n1,is2n1,irzbnd,isnx
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),aftshft,
     *                nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
     *                noffseg,ngrace,nvolt,ivlit(52),iplit(52),nlit,
     *                lenlit(52),multg(37),upg(37),slurg(37),slashg(37),
     *                naccg(74),voltxtq(6),litq(52)
      logical upg,slurg,slashg,issig,rpndot
      character*128 litq
      common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
     *               ndotmv(nm),updot(nm,20),rtdot(nm,20)
      integer istart(80),istop(80),iaskb(nm),numbms(nm),
     *        nornb(nm),ihornb(nm,24),lcwr(nm)
      character*1 ulfbq,udqq,clefq(nm),slurudq
      character*8 noteq
      character*79 cwrq(nm),notexq,inameq
      character*10 voltxtq
      common /comoct/ noctup
      character*80 soutq,headrq,lowerq
      common /comnsp/ space(80),nb,prevtn(nm),
     *    flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
      logical bspend,lower,cwrest(nm),vxtup,
     *        isgrace,isclef,nofirst,iscln,isdot,isflag,
     *        isacc,isfirst,flgndb,btest,stemup,upslur,
     *        isgaft,isarp,found1,isrshft,isaccs,
     *        lowdot,flipend,iscwr,isdotted
      real*4 ptgr(37),ptclef(nm),ptsndg(nm),eskndg(nm),tstart(80),
     *       squez(80)
      logical cwrferm
      common /comcwrf/ cwrferm(nm)
      common /comxtup/ ixtup,vxtup(nm),ntupv(nm),nolev1(nm),
     *                 islope(nm),xelsk(24),eloff(nm)
      common /comstart/ facmtr
      common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
     *                flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
     *                rtshfac
c
c  Factors for grace note, clef spacing. (fraction of wheadpt)
c  In 1.04, moved to block data subprogram
c
      common /comslur/ listslur,upslur(nm,2),ndxslur
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,idsig,
     *   lnam(nm),inameq(nm)
      common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
      common /comtol/ tol
      integer*2 mmidi
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
      logical slmon,dbltie
      common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
     *       naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
     *       slmon(0:nm),dbltie
      common /comevent/ miditime,lasttime
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
        vxtup(ivx) = .false.
25    continue
      naskb = 0
      ifig = 1
      ixtup = 0
      icashft = 0
      bspend = .false.
      iscwr = .false.
      rpndot = .false.
      do 16 ib = 1 , nb
c
c  Check for segno
c
        if (btest(iornq(1,ipo(istart(ib))),4) .and.
     *       ivxo(istart(ib)).eq.1) then
          if (noffseg.le.-10) then
            write(noteq(1:5),'(1H{,i3,1H})')noffseg
            lnoten = 5
          else if (noffseg.lt.0 .or. noffseg.ge.10) then
            write(noteq(1:4),'(1H{,i2,1H})')noffseg
            lnoten = 4
          else
            write(noteq(1:1),'(i1)')noffseg
            lnoten = 1
          end if
          notexq = sq//'znotes'//sq//'segnoo'//noteq(1:lnoten)//'9'
          lnote = 15+lnoten
          do 130 iv = 2 , nv
            notexq = notexq(1:lnote)//'&'//sq//'segnoo'
     *               //noteq(1:lnoten)//'9'
            lnote = lnote+lnoten+9
130       continue
          if (islast) write(11,'(a)')notexq(1:lnote)//sq//'en'
          lnote = 0
        end if
c
c  Check for new clefs
c
        isclef = .false.
        if (btest(islur(ivxo(istart(ib)),ipo(istart(ib))),15))
     *       then
c
c  In preceding line, fl32 gave wrong result for ... .gt.0 !!!
c
          do 140 in = istart(ib) , istop(ib)
            if (btest(islur(ivxo(in),ipo(in)),11)) then
              call wsclef(ivxo(in),ninow,clefq,
     *          iand(ishft(islur(ivxo(in),ipo(in)),-12),7))
            end if
140       continue
          if (islast) write(11,'(a)')sq//'pmxnewclefs'
          isclef = .true.
        end if
c
c  Start a notes group.  We're just gonna define every one using pnotes{n}, 
c    where \def\pnotes#1{\vnotes#1\elemskip}
c
        soutq = sq//'pnotes{'
        eonsqz = squez(ib)*feon(space(ib)/squez(ib))
        if (eonsqz .gt. 0.995) then
          write(soutq(9:12),'(f4.2)')eonsqz
        else if (eonsqz .gt. 0.095) then
          soutq = soutq(1:8)//'0.'
          write(soutq(11:12),'(i2)')nint(100*eonsqz)
        else
          soutq = soutq(1:8)//'0.0'
          write(soutq(12:12),'(i1)')nint(100*eonsqz)
        end if
        soutq = soutq(1:12)//'}'
        lsout = 13
c
c  Check whole block, flag accidentals etc that are too close, one per *time*.
c  Note about bar starts and after rpt's/boublebars: There is an afterruleskip
c    (fbar*wheadpt) following, but rpts seem to occupy some of that gap, so
c    (dotsfac*wheadpt) is presumed to be filled up.
c
        in = istart(ib)-1
        itrpt = -1
        itsig = -1
c
c  Begin big manual loop which ends at 112
c
111     in = in+1
        if (in .gt. istop(ib)) go to 112
        ip = ipo(in)
        ivx = ivxo(in)
        if (ivx .le. nv) then
          iv = ivx
        else
          do 128 iv = 1 , nv
            if (nvmx(iv) .eq. 2 .and. ivmx(iv,2).eq. ivx) go to 129
128       continue
        print*,'Trouble finding iv!, ivx,nvmx,ivmx:',ivx,nvmx(1),nvmx(2)
        print*,ivmx(1,1),ivmx(1,2),ivmx(2,1),ivmx(2,2)
          stop
        end if
129     continue
c
c  Remember, rpts & internal sigs can only come at start of (internal) block
c
        isacc = iand(nacc(ivx,ip),3) .gt. 0
        isaccs = isacc .or. btest(iornq(ivx,ip),0)
        isarp = btest(iornq(ivx,ip),27)
        if (btest(ipl(ivx,ip),10)) then
c
c  Check chord notes for accidentals and arpeggios.
c
          call chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isaccs,isarp,
     *                icashft)
        end if
c
c  When we get motivated, will do spacing for arpeggios here.
c
        if (ivx.eq.1 .and. iand(islur(ivx,ip),96).gt.0)
     *        itrpt = nint(to(in))
        issig  = btest(ipl(ivx,ip),28)
        if (ivx.eq.1 .and. issig) itsig = nint(to(in))
        isgrace = btest(islur(ivx,ip),4) .and.
     *    .not.btest(ipl(ivx,ip),29) .and. .not.btest(ipl(ivx,ip),31)
        isgaft = .false.
        if (ip .gt. 1) then
          xnd = tnote(iand(255,ipl(ivx,ip-1)))
          isgaft = btest(ipl(ivx,ip-1),29) .or. btest(ipl(ivx,ip-1),31)
          isgrace = isgrace .or. isgaft
        end if
        iscln = isclef .and. btest(islur(ivx,ip),11)
c
c  Is prev. note non-beamed, up-stemmed, & flagged? Recall if ip>1, have nd
c
        isflag = ip.gt.1 .and. xnd.gt.tol .and. xnd.lt.16.-tol
        if (isflag)
     *       isflag = .not.btest(irest(ivx,ip-1),0)
     *          .and. udqq(nolev(ivx,ip-1),
     *         ncmid(iv,ip-1),islur(ivx,ip-1),nvmx(iv),ivx,nv).eq.'u'
        if (isflag) then
          do 116 ibmchk = 1 , numbms(ivx)
            if (ip-1 .lt. ibm1(ivx,ibmchk)) then
              go to 117
            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
        if (isdot) isdot = isdotted(nodur,ivx,ip-1)
        isrshft = ip .gt. 1
        if (isrshft) isrshft = btest(irest(ivx,ip-1),20)
        if (.not.(isaccs.or.isgrace.or.iscln.or.isflag.or.isrshft.or.
     *          isdot.or.btest(iornq(ivx,ip),26).or.
     *          btest(irest(ivx,ip),21).or.isarp.or.
     *                    btest(irest(ivx,ip),27))) go to 111
c
c  Here is an accid,grace,clef,flag,rtshft,dot,udsp,arpeg,left-shift.
c  Check if need extra space.
c
        pts = wheadpt
        if (isgrace) then
          do 122 ig = 1 , ngrace
            if (.not. isgaft) then
              if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 123
            else if (ip .gt. 1) then
              if (ipg(ig).eq.ip-1 .and. ivg(ig).eq.ivx) go to 123
            end if
122       continue
          print*,'Problem finding grace index in makeabar'
          stop
123       continue
c
c  wgr = distance to backspace (in headwidths), less main acc.
c  ptgr = same in pts,+ main acc.  Not used for after-grace.
c  spgr = total space needed (w/o main acc). NB apt=wheadpt, don't get confused.
c   Also, spgr is same for b4 or after, but xb4fac-space will be in diff. place.
c
          if (nng(ig) .eq. 1) then
            wgr = grafac
            if (multg(ig) .eq. 0) wgr = wgr-.4
          else
            wgr = nng(ig)*emgfac
            do 126 ing = 2 , nng(ig)
              if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac
126         continue
          end if
          ptgr(ig) = wgr*wheadpt
          spgr = ptgr(ig)+xb4fac*wheadpt
          if (isaccs) ptgr(ig) = ptgr(ig) + accfac*wheadpt
          if (naccg(ngstrt(ig)) .gt. 0) spgr = spgr+wheadpt*agc1fac
          pts = pts+spgr
        end if
        if (iscln) then
          pts = pts+clefac*wheadpt
c
c  How far to backspace when printing the clef
c
          ptclef(ivx) = 0.
          if (isaccs) ptclef(ivx) = ptclef(ivx)+accfac*wheadpt
          if (isgrace) ptclef(ivx) = ptclef(ivx)+spgr
c     print*,'+CLEF, ptclef, pts->',ptclef(ivx),pts
        end if
        if (isrshft) then
          pts = pts+rtshfac*wheadpt
        else if (isflag) then
          pts = pts+flagfac*wheadpt
c     print*,'+FLAG, pts->',pts
        else if (isdot) then
          pts = pts+dotfac*wheadpt
c     print*,'+DOT, pts->',pts
        end if
        if (to(in) .eq. itrpt) then
c
c  Repeat, need a little extra space
c
          pts = pts+dotsfac*wheadpt
c     print*,'ITRPT, pts->',pts
        end if
        if (isarp) then
          pts = pts+arpfac*wheadpt
c     print*,'Due to isarp, pts, arpfac:',pts,arpfac
        end if
        if (btest(irest(ivx,ip),27)) pts = pts+wheadpt
        pts = pts+xspfac*wheadpt
c     print*,'FINISH, xspfac,pts->',xspfac,pts
c
c  Get available space in elemskips (esk)
c
        isfirst = ip.eq.1 .or. to(in).eq.itrpt .or.
     *        to(in) .eq. itsig
        if (isfirst) then
c
c  At start of bar or after repeat sign or new signature
c
          if (to(in) .eq. itsig) then
            esk = 0.
          else
            esk = fbar
          end if
        else
c
c  Not 1st note of bar
c
          esk = eskz(ivx,ip)-eskz(ivx,ip-1)
        end if
        if (isgrace) then
c
c  Since graces can be very long, cannot assume no interference if prior
c  note uses >1 noteskip.  So must get elsk's back to prior note, whether or
c  not it used only one noteskip.  But if it was xtup. don't need to call eskb4.
c
c          if ((ip.le.2 .or. nodur(ivx,ip-2).gt.0) .and.
          if ((ip.le.2 .or. nodur(ivx,max(1,ip-2)).gt.0) .and.
     *                                to(in).ne.itsig)
     *          call eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk)
        end if
c
c  Done getting available elemskips.  Remove headwidth it first.  Must do here
c  rather than earlier since check uses isfirst
c
        if (isfirst) pts = pts-wheadpt
        if (isaccs) then
c
c  Combine chord accidental space rqmts with main note, accounting for lshft's.
c  icashft already includes lshft's of chord notes.  First do main note a-shft
c
          ihshft = igetbits(nacc(ivx,ip),7,10)
c
c  Correct for main note left shift if needed
c
          if (btest(ipl(ivx,ip),8)) then
            if (ihshft .eq. 0) then
              ihshft = 44
            else
              ihshft = ihshft-20
            end if
          end if
          if (ihshft .ne. 0) ihshft = max(0,64-ihshft)
          ihshft = max(ihshft,icashft)
c
c  If there's a grace, correct amount of backspacing needed
c
          if (isgrace .and. ihshft.ne.0)
     *         ptgr(ig) = ptgr(ig)+.05*ihshft*wheadpt
        end if
c
c  Try big accidentals first
c
        ptbneed = pts
        if (isaccs) then
          ptbneed = ptbneed+wheadpt*bacfac
c
c  Now if there are *any* left-shifted accids and *any* left-shifted noteheads,
c  we must reduce pts by wheadpt since it was already included w/ accids.
c
          if (ihshft.gt.0) then
            if (btest(irest(ivx,ip),27)) ptbneed=ptbneed-wheadpt
            ptbneed = ptbneed+.05*ihshft*wheadpt
          end if
        end if
        if (poenom*esk .gt. ptbneed) then
c
c  Set flag for big accidental
c
          if (isacc) nacc(ivx,ip) = ibset(nacc(ivx,ip),3)
          go to 99
        end if
c
c  Cannot use big, so try small
c
        ptsneed = pts
        if (isaccs) then
          ptsneed = ptsneed+accfac*wheadpt
c
c  Repeated coding from above :-(
c
          if (ihshft.gt.0) then
            if (btest(irest(ivx,ip),27)) ptsneed = ptsneed-wheadpt
            ptsneed = ptsneed+.05*ihshft*wheadpt
          end if
        end if
        if (poenom*esk .lt. ptsneed) call addask(to(in),ptsneed,
     *              esk,fixednew,scaldold,0.,.false.)
99      continue
        if (icashft.gt.0) icashft = 0
        if (btest(iornq(ivx,ip),26)) then
c
c  User-defined space.  Warning, "zero" may change value in addask!
c
          zero = 0.
          call addask(to(in),ptsneed,zero,
     *                fixednew,scaldold,tglp1,.true.)
        end if
c
c  End of big manual loop over "in" for accidental checking
c
        go to 111
112     continue
c
c End of ask analysis for this block.  Check for internal repeat or sig change.
c
        if (ib.gt.1 .and. ivxo(istart(ib)).eq.1) then
          iirpt = iand(islur(1,ipo(istart(ib))),67109216)
          if (iirpt .gt. 0) then
c
c Internal repeat
c
            if (islast) write(11,'(a)')sq//'advance'//sq//'barno-1%'
            if (iirpt .eq. 96) then
              if (islast) write(11,'(a)')sq//'leftrightrepeat'
              fixednew = fixednew+lrrptfac*wheadpt
            else if (btest(iirpt,5)) then
              if (islast) write(11,'(a)')sq//'leftrepeat'
              fixednew = fixednew+rptfac*wheadpt
            else if (btest(iirpt,6)) then
              if (islast) write(11,'(a)')sq//'rightrepeat'
              fixednew = fixednew+rptfac*wheadpt
            else if (btest(iirpt,8)) then
              if (islast) write(11,'(a)')sq//'doublebar'
            else
              print*,'Unexpected mid-bar repeat command R*'
              stop 1
            end if
            scaldold = scaldold-fbar
          end if
          if (btest(ipl(1,ipo(istart(ib))),28)) then
c
c  Internal signature change.
c
            notexq = sq//'generalsignature{'
            lnote = 18
            if (isig .lt. 0) then
              notexq = notexq(1:lnote)//'-'
              lnote = lnote+1
            end if
            if (islast) write(11,'(a)')notexq(1:lnote)
     *          //chax(48+abs(isig))//'}%'
            if (islast) write(11,'(a)')sq//'zchangecontext'//sq
     *          //'addspace{-.5'//sq//'afterruleskip}%'
            lnote = 0
          end if
        end if
        flgndb = .false.
c
c  Done with start-of-block stuff.  Begin main loop over voices.
c
        do 11 iv = 1 , nv
        do 11 kv = 1 , nvmx(iv)
          ivx = ivmx(iv,kv)
          icm = midchan(iv,kv)
          figcheck = figbass .and. ivx.eq.1 .and. nfigs.gt.0
          if (ivx .gt. 1) then
            if (ivx .le. nv) then
              call addstr(sepsymq(iv-1),1,soutq,lsout)
            else
              call addstr(sq//'nextvoice',10,soutq,lsout)
            end if
          end if
          if (ihdht.gt.0 .and. ivx.eq.nv) then
c
c  Write header.  First adjust height if needed to miss barno.
c
            if (bar1syst .and. iline.ne.1) then
              ihdht = 15+irzbnd+isnx
            end if
c
c  Add user-defined vertical shift
c
            ihdht = ihdht+ihdvrt
            lchead = lenstr(headrq,80)
            notexq = sq//'zcharnote{'
            write(notexq(12:13),'(i2)')ihdht
            notexq = notexq(1:13)//'}{'//sq//'bigfont'//sq//'kern-30pt '
            call addstr(notexq,34,soutq,lsout)
            call addstr(headrq(1:lchead)//'}',1+lchead,soutq,lsout)
            ihdht = 0
          end if
          if (lower .and. ivx.eq.nv) then
            lclow = lenstr(lowerq,80)
            call addstr(sq//'zcharnote{-6}{'//
     *        sq//'tempo'//sq//'kern-10pt '//
     *        lowerq(1:lclow)//'}',33+lclow,soutq,lsout)
            lower=.false.
          end if
          tnow = tstart(ib)
          nofirst = .true.
c
c  Done setting up voice ivx for start of block ib.  Loop over notes in voice.
c
          do 10 jn = istart(ib), istop(ib)
            if (ivxo(jn) .ne. ivx) go to 10
            ip = ipo(jn)
            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.tnow-tol) then
c
c  Bypassed figure location. Backup, place fig, return.
c
              offnsk = (tnow-itfig(ifig))/space(ib)
              call putfig(ifig,offnsk,figcheck,soutq,lsout)
              go to 12
            end if
c
c  Put in \sk if needed
c
            if (to(jn) .gt. tnow+tol) then
              call addstr(sq//'sk',3,soutq,lsout)
              tnow = tnow+space(ib)
              go to 12
            end if
c
c  Check for user-defined shifts
c
            if (btest(irest(ivx,ip),15).or.btest(irest(ivx,ip),16))
     *             call putshft(ivx,.true.,soutq,lsout)
21          if (iaskb(ivx).le.naskb .and.
     *            tnow.gt.task(iaskb(ivx))-tol) then
              if (task(iaskb(ivx)) .gt. tstart(ib)-tol) then
c
c  Insert placeholder for accidental skip
c
                call addstr(sq//'ask     ',9,soutq,lsout)
                nasksys = nasksys+1
                wasksys(nasksys) = wask(iaskb(ivx))
                if (wask(iaskb(ivx)) .gt. 0.) then
                  elasksys(nasksys) = elask(iaskb(ivx))
                else
c
c  This is a signal to permit negative ask's.  Should really have elask>=0.
c
                  elasksys(nasksys) = -elask(iaskb(ivx))
                end if
              end if
c
c  May have skipped some task's in earlier blocks (due to void voice)
c
              iaskb(ivx) = iaskb(ivx)+1
              go to 21
            end if
            if (figcheck .and. abs(itfig(ifig)-tnow).lt.tol) 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)
              end if
            end if
c
c  Checking for literal TeX string BEFORE starting beams!!
c
            if (btest(islur(ivx,ip),16)) then
              do 124 il = 1 , nlit
                if (iplit(il).eq.ip .and. ivlit(il).eq.ivx) go to 125
124           continue
              print*,'Problem finding index for literal string'
              stop
125           continue
c
c  Write a type 1 tex string.
c
              if (lenlit(il) .lt. 71) then
c
c  Add normally
c
                call addstr(litq(il),lenlit(il),soutq,lsout)
              else
c
c  Longer than 71.  Write souq, Write string, start new soutq.
c
                if (islast) write(11,'(a)')soutq(1:lsout)//'%'
                if (islast) write(11,'(a)')litq(il)(1:lenlit(il))//'%'
                lsout = 0
              end if
            end if
c
c  Arpeggio on a main (non-chordal) note?
c
            if (btest(iornq(ivx,ip),27)) then
              call putarp(tnow,iv,nolev(ivx,ip),ncmid(iv,ip),
     *                    soutq,lsout)
            end if
c
c  See if a beam starts here
c
            if (numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx)
     *          .and. ibm1(ivx,ibmcnt(ivx)) .eq. ip) then
              if (.not.btest(irest(ivx,ip),24)) then
c
c  Not a jump start
c
                call beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib)
c
c  Shift beam start if notehead was shifted
c
                if (btest(ipl(ivx,ip),8)) then
                  call addstr(sq//'loff{',6,soutq,lsout)
                else if (btest(ipl(ivx,ip),9)) then
                  call addstr(sq//'roff{',6,soutq,lsout)
                end if
                if (lnote .gt. 0) call addstr(notexq,lnote,soutq,lsout)
                if (btest(ipl(ivx,ip),8) .or.
     *            btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout)
              end if
              if (ixrest(ivx) .eq. 0) then
                beamon(ivx) = .true.
                bspend = .true.
              end if
            end if
c
c  Setup for chords and possible slurs in chords
c
            if (btest(ipl(ivx,ip),10)) call precrd(ivx,ip,nolev(ivx,ip))
c
c  Is there slur or grace activity?
c
            isgrace = btest(islur(ivx,ip),4)
            if (ip .gt. 1) isgrace = isgrace.or.btest(ipl(ivx,ip-1),31)
c
c  isgrace if not 1st note in bar and previous note has Way-after grace.
c
            if (btest(islur(ivx,ip),0) .or. isgrace) then
              if (btest(islur(ivx,ip),0))
     *           call doslur(nolev(ivx,ip),isdat1,isdat2,isdat3,nsdat,
     *           ip,iv,kv,nv,beamon(ivx),ncmid(iv,ip),soutq,lsout,
     *           ulq(ivx,ibmcnt(ivx)),islur(ivx,ip),ipl(ivx,ip),
     *           iornq(ivx,ip),islhgt,tno(iand(255,ipl(ivx,ip))),
     *           nacc(ivx,ip))
              if (isgrace) then
c
c Grace note.
c
                iphold = ip
                isgrace = .false.
                if (ip .gt. 1) isgrace = btest(ipl(ivx,ip-1),31)
                if (isgrace) iphold = iphold-1
                isgrace = isgrace .or. (.not.btest(ipl(ivx,ip),31)
     *            .and..not.btest(ipl(ivx,ip),29))
c
c Place grace now if (a) Way-after from prev note and ip>1 or (b) Pre-grace
c   on current note.  Do A-grace on current note, and W-grace at barend, later.
c
                if (isgrace) then
                  call dograce(ivx,iphold,ptgr,soutq,lsout,ncmid(iv,ip),
     *                 nacc(ivx,ip),ig,ipl(ivx,iphold),.false.)
                  if (slurg(ig)) then
c
c Terminate slur started in dograce.  Get direction of main note stem
c
                    if (.not.beamon(ivx)) then
c
c  Separate note.  Get stem direction.
c
                      stemup = udqq(nolev(ivx,ip),ncmid(iv,ip),
     *                     islur(ivx,ip),nvmx(iv),ivx,nv) .eq. 'u'
                    else
c
c  In a beam
c
                      stemup = ulq(ivx,ibmcnt(ivx)) .eq. 'u'
                    end if
                    call endslur(stemup,.not.upg(ig),nolev(ivx,ip),0,
     *                 ndxslur,0,ncmid(iv,ip),soutq,lsout)
                  end if
                end if
              end if
              if (btest(iornq(ivx,ip),24)) then
c
c  Start slur on main note for After- or Way-after-grace.
c
c                ndxslur = log2(511-listslur)
                ndxslur = log2(4095-listslur)
c
c  Get note name
c
                call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
c
c  Get slur direction
c
                slurudq = 'u'
                if (.not.beamon(ivx)) then
                  if (udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
     *                  nvmx(iv),ivx,nv) .eq. 'u') slurudq = 'd'
                else
                   if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') slurudq = 'd'
                end if
c                notexq = sq//'islur'//slurudq//chax(48+ndxslur)
c     *              //noteq(1:lnoten)
c                call addstr(notexq,8+lnoten,soutq,lsout)
                if (ndxslur .lt. 10) then
                  notexq = sq//'islur'//slurudq//chax(48+ndxslur)
     *              //noteq(1:lnoten)
                  call addstr(notexq,8+lnoten,soutq,lsout)
                else
                  notexq = sq//'islur'//slurudq//'{1'//chax(38+ndxslur)
     *              //'}'//noteq(1:lnoten)
                  call addstr(notexq,11+lnoten,soutq,lsout)
                end if
                call setbits(ipl(ivx,ip),4,23,ndxslur)
                if (btest(ipl(ivx,ip),31))
c
c  Starting slur on W-grace on THIS note.  Record ndxslur.
c
     *                listslur = ibset(listslur,ndxslur)
              end if
            end if
c
c  Process dynamic marks
c
            if (btest(irest(ivx,ip),26)) call dodyn(ivx,ip,
     *          nolev(ivx,ip),ncmid(iv,ip),ipl(ivx,ip),islur(ivx,ip),
     *          nvmx(iv),nv,beamon(ivx),soutq,lsout)
c
c  Check for chord notes.  Moved up from below, 10/27/96 so chord orns done 1st.
c
            if (btest(ipl(ivx,ip),10)) then
c
c  Need a duration to set type of note head
c
c             if (.not. vxtup(ivx)) then
c
c  Clumsy test, but vxtup is not set until main note is processed.
c
              if (.not.(vxtup(ivx).or.btest(irest(ivx,ip),28))) then
                nodu = nodur(ivx,ip)
              else if (mult(ivx,ip) .lt. 0) then
                nodu = 32
              else
                nodu = 16
              end if
              call docrd(ivx,ip,nodu,ncmid(iv,ip),iv,tnow,soutq,lsout,
     *                   ulq,ibmcnt(ivx),islur(ivx,ip),nvmx(iv),nv,
     *                   beamon(ivx),nolev(ivx,ip),ihornb,nornb,stemlen)
            end if
c
c  Now that chords are done, add stuff to midi file
c
            if (ismidi) call addmidi(icm,nolev(ivx,ip),
     *          iand(nacc(ivx,ip),7),isig,tnote(iand(ipl(ivx,ip),255)),
     *          btest(irest(ivx,ip),0),.false.)
c
c  Check for main-note ornaments. ')' on dotted notes go in with note, not here.
c  Bits 0-13: (stmgx+Tupf._) ; 14: Down fermata, was F
c  15: Trill w/o "tr", was U , 16-18 edit. accid., 19-21 TBD
c
            isacc = iand(iornq(ivx,ip),4194287) .gt. 0
c
c  isacc=.true. if any ornament except segno
c
            if (btest(iornq(ivx,ip),13) .and. nodur(ivx,ip).gt.0) then
c
c  If ).  is only ornament, bypass.  If with others, temporarirly zero the bit.
c
              if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then
                if (iand(iornq(ivx,ip),516079) .eq. 0) then
c
c  ). is the only non-segno ornament
c
                  isacc = .false.
                else
c
c  There are other ornaments in addition
c
                  rpndot = .true.
                  iornq(ivx,ip) = ibclr(iornq(ivx,ip),13)
                end if
              end if
            end if
            if (isacc .and. .not.cwrferm(ivx)) then
c
c  Check for centered whole-bar rest with fermata (bits 10 or 14).
c
              if (iand(iornq(ivx,ip),17408).gt.0
     *                               .and. btest(irest(ivx,ip),0) .and.
     *             nodur(ivx,ip).eq.lenbar .and.
     *             .not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)) then
                cwrferm(ivx) = .true.
                go to 30
              end if
              call putorn(iornq(ivx,ip),nolev(ivx,ip),nolev(ivx,ip),
     *             nodur(ivx,ip),nornb,ulq,ibmcnt(ivx),ivx,ncmid(iv,ip),
     *             islur(ivx,ip),nvmx(iv),nv,ihornb,stemlen,
     *             notexq,lnote,ip,islhgt,beamon(ivx),
     *             btest(ipl(ivx,ip),10))
              call addstr(notexq,lnote,soutq,lsout)
            end if
            if (rpndot) then
              iornq(ivx,ip) = ibset(iornq(ivx,ip),13)
              rpndot = .false.
            end if
30          continue
c
c  Check for main note accidental
c
            if (iand(nacc(ivx,ip),3) .gt. 0) then
              call doacc(igetbits(nacc(ivx,ip),7,10)-64,
     *           igetbits(nacc(ivx,ip),6,4),btest(ipl(ivx,ip),8),
     *           notexq,lnote,nacc(ivx,ip),nolev(ivx,ip),ncmid(iv,ip))
              call addstr(notexq,lnote,soutq,lsout)
            end if
c
c  Lower dot for lower-voice notes.  Conditions are:
c   1. Dotted time value
c   2. Lower voice of two
c   3. Note is on a line
c   4. Not a rest
c.  5. Flag (lowdot) is set to true
c   6. Not in an xtuplet
c
            if (lowdot .and. nvmx(iv).eq.2 .and. ivx.le.nv
     *           .and. nodur(ivx,ip).ne.0) then
              if (.not.btest(irest(ivx,ip),0) .and.
     *            2**log2(nodur(ivx,ip)).ne.nodur(ivx,ip) .and.
     *            mod(nolev(ivx,ip)-ncmid(ivx,ip),2).eq.0) then
                if (btest(irest(ivx,ip),19)) then
c
c  Note already in movdot list.  Drop by 2.
c
                  updot(ivx,ndotmv(ivx)+1) =
     *                   updot(ivx,ndotmv(ivx)+1)-2.
                else
c
c  Not in list so just move it right now
c
                  call dotmov(-2.,0.,soutq,lsout,
     *                          igetbits(islur(ivx,ip),1,3))
                end if
              end if
            end if
c
c  Check for dotted notes with moved dots
c
            if (btest(irest(ivx,ip),19)) then
              ndotmv(ivx) = ndotmv(ivx)+1
              call dotmov(updot(ivx,ndotmv(ivx)),rtdot(ivx,ndotmv(ivx)),
     *           soutq,lsout,igetbits(islur(ivx,ip),1,3))
            end if
c
c  Zero out slur-height marker for raising ornaments
c
            islhgt = 0
c
c  Now start with spacing notes.  Is a beam start pending?
c
            if (bspend .and.
     *            ibm2(ivx,ibmcnt(ivx)).gt.ibm1(ivx,ibmcnt(ivx))) then
              if (ixrest(ivx) .eq. 4) then
c
c  Special path for single note at end of otherwise beamed xtup
c
                ixrest(ivx) = 0
              else
                call beamn1(notexq,lnote)
              end if
              bspend = .false.
c
c  Is a beam ending?
c
            else if (numbms(ivx).gt.0 .and. ibmcnt(ivx).le.numbms(ivx)
     *           .and. ibm2(ivx,ibmcnt(ivx)) .eq. ip) then
              if (bspend) then
c
c  Must be a single-note ending of a jump-beam
c
                isbjmp = .true.
                bspend = .false.
              end if
              call beamend(notexq,lnote)
              vxtup(ivx) = .false.
              nornb(ivx) = 0
              ibmcnt(ivx) = ibmcnt(ivx)+1
              beamon(ivx) = .false.
c
c  Or if we're in the middle of a beam
c
            else if (numbms(ivx).gt.0 .and. beamon(ivx)) then
              call beamid(notexq,lnote)
c
c      Or whole-bar rest
c
            else if (btest(irest(ivx,ip),0)
     *          .and. nodur(ivx,ip).eq.lenbar
     *          .and..not.(firstgulp.and.ibar.eq.1.and.lenb0.gt.0)
     *          .and..not.btest(irest(ivx,ip),25)
     *          .and..not.btest(islur(ivx,ip),29)) then
c
c  Rule out pickup bar, blank rests, non-centered.  Remember islur b19=> rp
c
              cwrest(ivx) = .true.
              iscwr = .true.
              call notex(cwrq(ivx),lcwr(ivx))
              tnow = tnow+lenbar
              go to 10
            else if (ixrest(ivx) .eq. 0) then
c
c  Write a separate note
c
              call notex(notexq,lnote)
            end if
c
c  Right offset?  This may cause trouble
c
            if (btest(ipl(ivx,ip),8)) then
              call addstr(sq//'loff{',6,soutq,lsout)
            else if (btest(ipl(ivx,ip),9)) then
              call addstr(sq//'roff{',6,soutq,lsout)
            end if
            if (ixrest(ivx).eq.0 .and. lnote.gt. 0)
     *                call addstr(notexq,lnote,soutq,lsout)
            if (btest(ipl(ivx,ip),8) .or.
     *          btest(ipl(ivx,ip),9)) call addstr('}',1,soutq,lsout)
c
c  Terminate user-defined offsets.  Fix format
c
            if (btest(irest(ivx,ip),15) .or. btest(irest(ivx,ip),17))
     *          call putshft(ivx,.false.,soutq,lsout)
c
c  Deal with After- and Way-after-graces.  First, if end of bar, compute space
c    needed since it wasn't done during general ask-checks. If extra space is
c    rq'd, convert GW to GA.  Therefore GW at end of bar never needs extra sp.
c    But will still need to add extra space as hardspace.
c
            if (ip.eq.nn(ivx) .and. (btest(ipl(ivx,ip),31).or.
     *                               btest(ipl(ivx,ip),29))) then
              do 77 ig = 1 , ngrace
                if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 78
77            continue
              print*,'Problem finding grace index at "do 77"'
              stop 1
78            continue
c
c  Get elemskip to end of bar.  WON'T WORK IF XTUPS !!
c
              esk = 0.
              do 40 iib = ib , nb
                if (iib .eq. ib) then
                  itleft = nint(to(iand(255,ipl(ivx,ip))))
                else
                  itleft = nint(tstart(ib))
                end if
                if (iib .lt. nb) then
                  itright = nint(tstart(iib+1))
                else
                  itright = lenbar
                end if
                esk = esk+feon(space(ib))*
     *                          (itright-itleft)/space(ib)
40            continue
              ptsavail = poenom*esk-wheadpt
              if (nng(ig) .eq. 1) then
                wgr = grafac
              else
                wgr = nng(ig)*emgfac
                do 41 ing = 1 , nng(ig)
                  if (naccg(ngstrt(ig)-1+ing) .gt. 0) wgr = wgr+acgfac
41              continue
              end if
              ptgr(ig) = wgr*wheadpt
              ptsneed = (wgr+0.5)*wheadpt
              ptsndg(ivx) = 0.
              if (ptsavail .lt. ptsneed) then
                ptsndg(ivx) = ptsneed
                eskndg(ivx) = esk
                if (btest(ipl(ivx,ip),31)) then
c
c  Convert GW to GA
c
                  ipl(ivx,ip) = ibset(ibclr(ipl(ivx,ip),31),29)
                end if
              end if
            end if
c
c  Check for GA
c
            if (btest(ipl(ivx,ip),29))
     *        call dograce(ivx,ip,ptgr,soutq,lsout,ncmid(iv,ip),
     *            nacc(ivx,ip),ig,ipl(ivx,ip),.false.)
c
c  Update running time
c
            tnow = tnow+space(ib)
10        continue
c
c  Have finished last note in this voice and block
c
          itendb = nint(to(istop(ib))+space(ib))
17        if (figcheck .and. itfig(ifig).lt.itendb) then
c
c  There's at least one figure left. offnsk could be <0
c
            offnsk = (tnow-itfig(ifig))/space(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 = ipo(iand(255,ipl(ivx,nn(ivx))))
            flgndv(ivx) = 0.
            if (abs(tnote(iand(255,ipl(ivx,ip)))-space(ib)).lt.tol) then
              if (space(ib) .lt. 16.-tol) then
c
c  Note in last space, smaller than a quarter note.
c
                if ((.not.btest(irest(ivx,ip),0) .and.
     *             udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
     *             nvmx(iv),ivx,nv).eq.'u')
     *            .or. isdotted(nodur,ivx,ip)) then
c
c  Upstem non-rest, or dotted
c
                  if (numbms(ivx).gt.0
     *              .and. ip.eq.ibm2(ivx,max(1,numbms(ivx)))
     *              .and. .not.isdotted(nodur,ivx,ip))
     *               then
c
c  In beam and not dotted, so use smaller space
c
                    flgndv(ivx) = upstmfac
                  else
                    flgndv(ivx) = flagfac
                  end if
                end if
              else
c
c  Last space, nonflagged (no beam) only worry dot or up
c
                if (isdotted(nodur,ivx,ip)) then
                  flgndv(ivx) = flagfac
                else if (tnote(iand(255,ipl(ivx,ip))).lt.64 .and.
     *              udqq(nolev(ivx,ip),ncmid(iv,ip),islur(ivx,ip),
     *                   nvmx(iv),ivx,nv).eq.'u') then
c
c  Upstem on last note , non-flagged
c
                  flgndv(ivx) = upstmfac
                end if
              end if
            end if
c
c  Check for right-shifted chordal note
c
            if (btest(irest(ivx,ip),20)) flgndv(ivx) = rtshfac
            flgndb = flgndb .or. flgndv(ivx).gt.0.
            if (ismidi) then
c
c  For midi, set flags for accidentals on last note of bar.  Assume they affect 
c    first note of next bar whether or not tied.  
c  Note has already been done, so next entry into addmidi is 1st in new bar.
c  First do main note, then chord notes
c
c  Gyrations needed to account for multi-bar tied full-bar notes?
cc  Old old    lbacc(icm) = iand(nacc(ivx,ip),7)
c   New old    if (lbacc(icm).eq.0) lbacc(icm) = iand(nacc(ivx,ip),7)
c
              if (iand(nacc(ivx,ip),7) .gt. 0) then
c
c  Explicit accidental on last main note in bar
c
                do 55 kacc = 1 , naccbl(icm)
                  if (laccbl(icm,kacc) .eq. nolev(ivx,ip)) go to 56
55              continue
                naccbl(icm) = naccbl(icm)+1
                laccbl(icm,naccbl(icm)) = nolev(ivx,ip)
                jaccbl(icm,naccbl(icm)) = iashft(iand(nacc(ivx,ip),7))
              end if
56            continue
              if (btest(ipl(ivx,ip),10) .and. crdacc) then
                do 57 icrd = icrd1 , icrd2
                  iacc = igetbits(icrdat(icrd),3,20)
                  if (iacc .gt. 0) then
c
c  Explicit accidental on chord note at end of bar
c
                    nolevc = igetbits(icrdat(icrd),7,12)
                    do 58 kacc = 1 , naccbl(icm)
                      if (laccbl(icm,kacc) .eq. nolevc) go to 59 
58                  continue
                    naccbl(icm) = naccbl(icm)+1
                    laccbl(icm,naccbl(icm)) = nolevc
                    jaccbl(icm,naccbl(icm)) = iashft(iacc)
                  end if
59                continue
57              continue
              end if
c              if (lbacc(icm).eq.0 .and. accb4(icm)) then
              do 65 kacc = 1 , naccim(icm) 
c
c  If naccim(icm)>0, 
c  possible implicit accidental from earlier in the bar.  Check for prior accid 
c  in this bar at relevant note levels, main and chord notes.  Only act if no
c  explicit action from just above.  Assuming any accid on last note in bar,
c  either explicit or implicit, has same effect on 1st note of next bar. 
c
                if (nolev(ivx,ip) .eq. laccim(icm,kacc)) go to 66
                if (btest(ipl(ivx,ip),10)) then
                  do 67 icrd = icrd1 , icrd2
                    if (iand(ishft(icrdat(icrd),-12),127) .eq.
     *                                 laccim(icm,kacc)) go to 66
67                continue
                end if
                go to 65
66              continue
c
c  So far we know there is a main or chord note at level laccim(icm,kacc). So
c   it will get a bl-accid if it didn't just already get one.
c
                do 68 macc = 1 , naccbl(icm)
                  if (laccbl(icm,macc) .eq. laccim(icm,kacc)) go to 65 
68              continue
                naccbl(icm) = naccbl(icm)+1
                laccbl(icm,naccbl(icm)) = laccim(icm,kacc)
                jaccbl(icm,naccbl(icm)) = jaccim(icm,kacc)
65            continue
            end if
          end if
11      continue
c
c  Close out the notes group
c
        call addstr(sq//'en',3,soutq,lsout)
        if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%'
16    continue
c
c  Check for way-after graces at end of bar.  We could not link these to notes
c  as in midbar since there is no note following grace!  Also, set flag if
c  hardspace is needed. Also, save nvmx, ivmx for use in space checks on reloop.
c
      isgrace = .false.
      do 75 iv = 1 , nv
      nvmxsav(iv) = nvmx(iv)
      do 75 kv = 1 , nvmx(iv)
        ivmxsav(iv,kv) = ivmx(iv,kv)
        ivx = ivmx(iv,kv)
        ptsgnd = 0.
        if ((btest(ipl(ivx,nn(ivx)),29).or.btest(ipl(ivx,nn(ivx)),31))
     *      .and. ptsndg(ivx).gt.0.) then
          flgndb = .true.
          if (ptsndg(ivx) .gt. ptsgnd) then
            ptsgnd = ptsndg(ivx)
            eskgnd = eskndg(ivx)
          end if
        end if
        if (btest(ipl(ivx,nn(ivx)),31)) then
c
c  This voice has a way-after grace here at end of bar
c
          if (.not.isgrace) then
c
c  This is the first one, so set up the string
c
            isgrace = .true.
            ivlast = 1
            soutq = sq//'znotes'
            lsout = 7
          end if
          do 76 iiv = ivlast , iv-1
            call addstr(sepsymq(iiv),1,soutq,lsout)
76        continue
          ivlast = iv
c
c  No need to put in 'nextvoice', even if 2 lines/staff
c
          call dograce(ivx,nn(ivx),ptgr,soutq,lsout,ncmid(iv,nn(ivx)),
     *      nacc(ivx,nn(ivx)),ig,ipl(ivx,nn(ivx)),.true.)
        end if
75    continue
      if (isgrace) then
        call addstr(sq//'en%',4,soutq,lsout)
        if (islast .and. lsout .gt. 0) write(11,'(a)')soutq(1:lsout)
      end if
      lsout = 0
c
c  Write multibar rest.  Assuming nv = 1  and do not worry about cwbrest
c  This has to be the only use of atnextbar
c
      if (ibar .eq. ibarmbr) then
        call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes'//sq//
     *              'mbrest{',30,soutq,lsout)
        ndig = int(alog10(mbrest+.01))+1
        write(soutq(31:33),'(i'//chax(48+ndig)//')')mbrest
        lsout = lsout+ndig
        call addstr('}{',2,soutq,lsout)
        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'//chax(48+ndig)//')')mtrspc
        lsout = lsout+ndig
        call addstr('}0'//sq//'en}%',7,soutq,lsout)
        if (islast) write(11,'(a)')soutq(1:lsout)
        lsout = 0
        ndig = int(alog10(mbrest-1+.01))+1
        if (mbrest.eq.1) ndig=1
        if (islast) write(11,'(a14,i'//chax(48+ndig)//',a1)')
     *      sq//'advance'//sq//'barno',mbrest-1,'%'
      else if (iscwr) then
c
c  Centered whole-bar rests
c
        call addstr(sq//'def'//sq//'atnextbar{'//sq//'znotes',22,
     *              soutq,lsout)
        do 60 iv = 1 , nv
          lnote = 0
          do 61 kv = 1 , nvmx(iv)
            ivx = ivmx(iv,kv)
            if (cwrest(ivx)) then
              if (lnote .eq. 0) then
                notexq = sq//'centerbar{'
                lnote = 11
              end if
c              notexq = notexq(1:lnote)//cwrq(ivx)(1:lcwr(ivx))
c              lnote = lnote+lcwr(ivx)
c              if (cwrferm(ivx)) then
cc
cc  Fermata on centered rest.  Will need to fix up level.
cc
c                notexq = notexq(1:lnote)//sq//'fermataup7'
c                lnote = lnote+11
c                cwrferm(ivx) = .false.
c              end if

              if (.not.cwrferm(ivx)) then
                notexq = notexq(1:lnote)//cwrq(ivx)(1:lcwr(ivx))
                lnote = lnote+lcwr(ivx)
              else
c
c  Fermata on centered rest.  Will need to fix up level.
c
                notexq = notexq(1:lnote)
     *                   //sq//'fermataup7'//cwrq(ivx)(1:lcwr(ivx))
                lnote = lnote+11+lcwr(ivx)
                cwrferm(ivx) = .false.
              end if
            end if
61        continue
          if (lnote .gt. 0) call addstr(notexq(1:lnote)//'}',lnote+1,
     *                  soutq,lsout)
          if (iv .ne. nv) call addstr(sepsymq(iv),1,soutq,lsout)
60      continue
        call addstr(sq//'en}',4,soutq,lsout)
        if (islast.and.lsout .gt. 0) write(11,'(a)')soutq(1:lsout)//'%'
      end if
c
c  End of block for centered whole-bar rests and multi-bar rests
c
c  If at end of block, save durations of last notes in bar, for possible use
c  if clef changes at start of next bar
c
      if (ibar .eq. nbars) then
        do 63 iv = 1 , nv
        do 63 kv = 1 , nvmx(iv)
          ivx = ivmx(iv,kv)
c          prevtn(ivx) = tnote(iand(ipl(ivx,nn(iv)),255))
          prevtn(ivx) = tnote(iand(ipl(ivx,nn(ivx)),255))
63      continue
      end if
c
c  Update time for midi.  This is only used for the event track
c
      if (ismidi) then
        miditime = miditime+15*lenbar
c
c  If pickup, write the real time signature to the event track.  Cannot use
c    mtrnuml since it was reset to 0, have to recompute it
c
        if (lenb0 .eq. lenbar) 
     *        call midievent('m',mtrdenl*lenb1/64,mtrdenl)
      end if
      return
      end
      subroutine make1bar(ibmrep,tglp1,tstart,cwrest,squez,
     *    istop,numbms,istart)
      parameter (nm=12,mv=24576)
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      character*6 figq
      character*1 ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,isfig,bar1syst
      common /comfig/ itfig(74),figq(74),nfigs
      common /combeam/ ibmtyp
      common /comask/ bar1syst,fixednew,scaldold,
     *                wheadpt,fbar,poenom
      common /comas1/ naskb,task(20),wask(20),elask(20)
      common /comas2/ nasksys,wasksys(400),elasksys(400)
      common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
      common /comfb/ nfb(nm),t1fb(nm,20),t2fb(nm,20),ulfbq(nm,20),ifb
      common /comsln/ is1n1,is2n1,irzbnd,isnx
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),aftshft,
     *                nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
     *                noffseg,ngrace,nvolt,ivlit(52),iplit(52),nlit,
     *                lenlit(52),multg(37),upg(37),slurg(37),slashg(37),
     *                naccg(74),voltxtq(6),litq(52)
      logical upg,slurg,slashg
      character*128 litq
      common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
     *               ndotmv(nm),updot(nm,20),rtdot(nm,20)
      integer cnn(nm),istart(80),istop(80),nxtnow(nm),ifbnow(nm),
     *        numbms(nm),mapfb(16)
      real*4 xit(nm),t1xtup(20),tstart(80),squez(80)
      character*1 ulfbq
      character*79 inameq
      character*10 voltxtq
      common /comoct/ noctup
      character*80 headrq,lowerq
      logical cwrferm
      common /comcwrf/ cwrferm(nm)
      common /comnsp/ space(80),nb,prevtn(nm),
     *    flgndv(nm),flgndb,eskgnd,ptsgnd,ivmxsav(nm,2),nvmxsav(nm)
      logical lower,cwrest(nm),vxtup,flgndb,btest,upslur,
     *        infbmx(nm),lowdot,inxtup(nm)
      common /comxtup/ ixtup,vxtup(nm),ntupv(nm),nolev1(nm),
     *                 islope(nm),xelsk(24),eloff(nm)
      common /comstart/ facmtr
      common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
     *                flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
     *                rtshfac
c
c  Above are factors for grace note, clef spacing. (fraction of wheadpt)
c  In 1.04, moved to block data subprogram
c
      common /comslur/ listslur,upslur(nm,2),ndxslur
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,idsig,
     *   lnam(nm),inameq(nm)
      common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      common /comtol/ tol
      integer*2 mmidi
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
      if (ismidi) then
c
c  Initialize for this bar the accidental counter for the midi file.  
c    naccim(icm) = # of accidentals from earlier in the bar
c
        do 45 iv = 1 , nv
        do 45 kv = 1 , nvmx(iv)
          naccim(midchan(iv,kv)) = 0
45      continue
      end if
c
c  Time from start of gulp to end of bar, used with forced beams
c
      tglp2 = lenb0+ibar*lenb1
      if (lenb0 .gt. 0) tglp2 = tglp2-lenb1
      tglp1 = tglp2-lenbar
c
c  infbmx will only be true if in xtup that is NOT in explicit forced beam.
c
      do 1 iv = 1 , nv
      do 1 kv = 1 , nvmx(iv)
        ivx = ivmx(iv,kv)
        cwrest(ivx) = .false.
        infbmx(ivx) = .false. 
        inxtup(ivx) = .false.
        if (ibar .gt. 1) then
          nn(ivx) = nib(ivx,ibar)-nib(ivx,ibar-1)
        else
          nn(ivx) = nib(ivx,ibar)
        end if
1     continue
c
c initialize list note counter, time(iv), curr. note(iv).  The loop to 4
c   ONLY initializes each voice.
c
      in = 1
      nxtup = 0
      narp = 0
      do 4 iv = 1 , nv
      do 4 kv = 1 , nvmx(iv)
        ivx = ivmx(iv,kv)
        cwrferm(ivx) = .false.
        cnn(ivx) = 1
        ivxo(in) = ivx
        ipo(in) = cnn(ivx)
        tnote(in) = fnote(nodur,ivx,1)
        to(in) = 0.
        xit(ivx) = tnote(in)
c
c  Note that xit(ivx) is to END of note in voice, but it1xtup is start time.
c
        if (nodur(ivx,ipo(in)) .eq. 0) then
c
c  First note of xtuplet at start of bar in voice ivx.
c
          nxtup = nxtup+1
          nxtnow(ivx) = nxtup
          inxtup(ivx) = .true.
          t1xtup(nxtup) = 0.
c
c  Xtup at start of bar.  If no explicit forced beam, start one, set 
c  signal infbmx, and save number ifbnow for use at termination.
c
          if (nfb(ivx) .gt. 0) then
            do 60 ifb = 1 , nfb(ivx)
              if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
c
c  No explicit fb here; so exit loop and insert one.  
c
                go to 61
              else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and.
     *                t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
c
c  IS explicit fb here; must NOT insert one
c
                go to 62
              end if
60          continue
          end if
61        continue
c
c  If here, xtup isn't in explicit fb, so must insert one
c
          infbmx(ivx) = .true.
          call addfb(nfb,ivx,t1xtup(nxtup)+
     *            tglp1,t1fb,t2fb,ulfbq,ifbadd)
          ifbnow(ivx) = ifbadd
        end if
62      continue
        if (abs(xit(ivx)-lenbar) .lt. tol) xit(ivx) = 1000.
        in = in+1
4     continue
c
c  Build the list:  This is a manual loop starting at 5
c
5     continue
c
c  Determine which voice comes next from end of notes done so far.
c  tmin is the earliest ending time of notes done so far
c
      tmin = 1000.
      do 6 iiv = 1 , nv
      do 6 kv = 1 , nvmx(iiv)
        iivx = ivmx(iiv,kv)
        tminn = min(tmin,xit(iivx))
        if(tminn .lt. tmin-tol) then
          tmin = tminn
          ivx = iivx
        end if
6     continue
      if (abs(tmin-1000.) .lt. tol) go to 7
      ivxo(in) = ivx
      cnn(ivx) = cnn(ivx)+1
      ipo(in) = cnn(ivx)
      to(in) = tmin
c
c  Check if this voice is done
c
      tnote(in) = fnote(nodur,ivx,cnn(ivx))
      if (cnn(ivx) .eq. nn(ivx)) then
        xit(ivx) = 1000.
      else
        xit(ivx) = xit(ivx)+tnote(in)
      end if
c
c  Flag xtups
c
      if (nodur(ivx,cnn(ivx)) .eq. 0) then
        if (.not.inxtup(ivx)) then
c
c  First note of xtup, not at start of bar.
c
          nxtup = nxtup+1
          nxtnow(ivx) = nxtup
          inxtup(ivx) = .true.
          t1xtup(nxtup) = xit(ivx)-tnote(in)
c
c  (Note: can't be on last note in voice, so xit(ivx) <> 1000)
c  Put xtuplet in a forced beam if not already in forced beam
c
          if (nfb(ivx) .gt. 0) then
            do 70 ifb = 1 , nfb(ivx)
              if (t1fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
c
c  NO explicit bm; put one in
c
                go to 71
              else if (t1fb(ivx,ifb) .lt. tglp1+xit(ivx)+tol .and.
     *              t2fb(ivx,ifb) .gt. tglp1+xit(ivx)+tol) then
c
c  IS explicit bm.  Don't put one
c
                go to 72
              end if
70          continue
          end if
71        continue
c
c  If here, no explicit bm, so put one in
c
          infbmx(ivx) = .true.
          call addfb(nfb,ivx,t1xtup(nxtup)+tglp1,
     *             t1fb,t2fb,ulfbq,ifbadd)
          ifbnow(ivx) = ifbadd
        end if
72      continue
      else if (inxtup(ivx)) then
c
c  This test is sufficient because already know nodur>0
c
        inxtup(ivx) = .false.
        if (infbmx(ivx)) then
c
c  Xtup is in auto-forced beam, so end it  
c
          t2fb(ivx,ifbnow(ivx)) = 
     *            t1xtup(nxtnow(ivx))+nodur(ivx,cnn(ivx))+tglp1
          infbmx(ivx) = .false.
        end if
      end if
      if (btest(irest(ivxo(in),ipo(in)),24)) then
c
c  For staff jumped beam, flag the first note (lowest voice) at same time
c
        inj = in
        if (ivxo(in) .gt. 1) then
          do 40 iin = in-1 , 1 , -1
            if (to(iin)+tol .lt. to(in)) go to 41
            if (abs(to(iin)-to(in)) .lt. tol) then
              inj = iin
              go to 40
            end if
40        continue
        end if
41      continue
        irest(ivxo(inj),ipo(inj)) = ibset(irest(ivxo(inj),ipo(inj)),29)
      end if
      in = in+1
      go to 5
7     continue
      ntot = in-1
      do 8 in = 1 , ntot-1
        tno(in) = to(in+1)-to(in)
8     continue
      tno(ntot) = tnote(ntot)
c
c  Debug writes
c
c      write(*,'()')
c      write(*,'(a)')' Greetings from PMXB'
c      write(*,'(16i5)')(ivxo(in),in=1,ntot)
c      write(*,'(16i5)')(ipo(in),in=1,ntot)
c      write(*,'(16f5.1)')(to(in),in=1,ntot)
c      write(*,'(16f5.1)')(tno(in),in=1,ntot)
c      write(*,'(16i5)')(nodur(ivxo(in),ipo(in)),in=1,ntot)
c      write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in)),in=1,ntot)
c
c  Done w/ list. Loop for parsing into note blocks:
c
      ib = 1
      istart(1) = 1
      space(1) = 0.
      in = 1
c
c  A manual loop to set space(ib) and istop(ib)
c
9     continue

        ivx = ivxo(min(in+1,ntot))
        ip = ipo(min(in+1,ntot))
        isl = islur(ivx,ip)
        if (in.eq.ntot .or. ((ivx.eq.1 .and.
     *       (iand(isl,67109216).gt.0 .or. btest(ipl(1,ip),28)
c    *      .or. ornq(1,ip).eq.'g')) .or. btest(isl,15) )) then
c  Bits 1-13: stmgx+Tupf._)
c  14: Down fermata, was F
c  15: Trill w/o "tr", was U
     *      .or. btest(iornq(1,ip),4))) .or. btest(isl,15) )
c
c  Checking for start of 2nd part of jumped beam
c
     *      .or. btest(irest(ivx,ip),29) ) then
c
c  Bar end, segno, int. rpt or sig change, clef,end of 1st part of jumped beam;
c    flow out of if-loop and into block-wrapup
c
c  10/18/97:  Problem with clef alignment.  Got isl{15} set on lowest-numbered
c  voice, but it wasn't first in the list at the same time.  So check if
c  prior notes in list have same time
c  5/25/98: This stuff causes trouble with just "c2 Ct c", maybe when clef
c  changes on last note in the list?
c
          if (btest(isl,15) .and. in.lt.ntot) then
            do 50 iin = in , 1 , -1
              if (tno(iin) .gt. tol) then
                in = iin
                islur(ivx,ip) = ibclr(islur(ivx,ip),15)
                islur(ivxo(in+1),ipo(in+1)) =
     *             ibset(islur(ivxo(in+1),ipo(in+1)),15)
                go to 51
              end if
50          continue
51          continue
          end if
          if (space(ib) .lt. tol) then
            space(ib) = tno(in)
            squez(ib) = 1.
          end if
          istop(ib) = in
        else if (space(ib) .lt. tol) then
c
c  space hasn't been set yet, so tentatively set:
c
          space(ib) = tno(in)
          if (space(ib) .lt. tol) then
            in=in+1
          else
            squez(ib) = getsquez(in,ntot,space(ib),tnote,to)
            istop(ib) = in
          end if
          go to 9
        else if (tno(in+1) .lt. tol) then
c
c  This is not the last note in the group, so
c
          in = in+1
          go to 9
        else if (abs(tno(in+1)-space(ib)) .lt. tol) then
          xsquez = getsquez(in+1,ntot,space(ib),tnote,to)
          if (abs(xsquez-squez(ib)) .lt. tol) then
c
c  Keep spacing the same, update tentative stop point
c
            in = in+1
            istop(ib) = in
            go to 9
          end if
        end if
c
c At this point istart and istop are good, so finalize block
c
        tstart(ib) = to(istart(ib))
        if (istop(ib) .eq. ntot) go to 15
        ib = ib+1
        istart(ib) = istop(ib-1)+1
        in = istart(ib)
c
c Set tentative block space and squeeze-factor for upcoming block
c
        space(ib) = tno(in)
        if (space(ib).gt.tol) 
     *        squez(ib)= getsquez(in,ntot,space(ib),tnote,to)
        istop(ib) = in
      go to 9
15    continue
      nb = ib
c
c  Invert the list of places into ipl(0-7), making it easier to analyze a voice
c
      do 13 in = 1 , ntot
        ipl(ivxo(in),ipo(in)) = ior(ipl(ivxo(in),ipo(in)),in)
13    continue
c
c  Compute elemskips from start of bar to each note in the bar, for beam slopes
c
      eskzb = 0.
      ib = 1 
      do 30 in = 1 , ntot
        if (in .eq. istart(ib)) then
          deskb = squez(ib)*feon(space(ib)/squez(ib))
        else if (tno(in-1) .gt. tol) then 
          eskzb = eskzb+deskb
        end if
        eskz(ivxo(in),ipo(in)) = eskzb
        if (in .eq. istop(ib)) then
          eskzb = eskzb+deskb
          ib = ib+1
        end if
30    continue
c
c  Debug writes
c
c      print*
c      write(*,'(16f5.1)')(eskz(ivxo(in),ipo(in)),in=1,ntot)
c      print*,'PMXB has now got blocks'
c      write(*,'(16i5)')(istart(ib),ib=1,nb)
c      write(*,'(16i5)')(istop(ib),ib=1,nb)
c      write(*,'(16f5.1)')(space(ib),ib=1,nb)
c      write(*,'(16f5.1)')(squez(ib),ib=1,nb)
c      write(*,'(16f5.1)')(fnote(nodur,ivxo(in),ipo(in)),in=1,ntot)
cc     write(*,'(26i3)')(iand(islur(ivxo(in),ipo(in)),30720)/2048,
c    *                  in=1,ntot)
c     write(*,'(1x,26a3)')(ornq(ivxo(in),ipo(in)),in=1,ntot)
c
c
c  Analyze for beams.
c
      do 20 iv = 1 , nv
      do 20 kv = 1 , nvmx(iv)
        ivx = ivmx(iv,kv)
        numbms(ivx) = 0
        mapfb(1) = 0
        mapfb(2) = 0
        mapfb(3) = 0
        mapfb(4) = 0
c
c  First forced beams.
c
        if (nfb(ivx) .gt. 0) then
c
c  tglp2 is time from start of gulp to end of current bar.
c
          nfbbar = 0
          do 80 ifb = 1 , nfb(ivx)
            if (t1fb(ivx,ifb).gt.tglp2-tol) go to 81
            nfbbar = nfbbar+1
            numbms(ivx) = numbms(ivx)+1
            numnew = numbms(ivx)
c
c  Times from beginning of bar
c
            itbb1 = int(t1fb(ivx,ifb)-tglp1+tol)
            itbb2 = int(t2fb(ivx,ifb)-tglp1+tol)
            do 83 ip = 1 , nn(ivx)
              if (int(to(iand(255,ipl(ivx,ip)))+tol) .eq. itbb1) then
                nip1fb = ip
                do 84 ip1 = ip , nn(ivx)
c                  if (to(iand(255,ipl(ivx,ip1)))+nodur(ivx,ip1)
c     *                     .eq.itbb2) then
                  inip1 = iand(255,ipl(ivx,ip1))
                  if (abs(to(inip1)+tnote(inip1)-itbb2) .lt. tol) then
                    nip2fb = ip1
                    itbb3 = itbb2-2
                    go to 85
                  end if
84              continue
              end if
83          continue
            print*,'Timing problem w/ fixed beams'
85          continue
            call logbeam(numnew,nip1fb,nip2fb)
c
c  Set up mapfb for forced beam just logged:
c
            ib1 = itbb1/2
            ib2 = itbb3/2
            ibrep = lenbar/ibmrep/2
            do 86 irep = 1 , ibmrep
              ib1now = max(0,ib1-(irep-1)*ibrep)
              ib2now = min(irep*ibrep-1,ib2-(irep-1)*ibrep)
              mapnow = 0
              do 87 ib = ib1now , ib2now
                mapnow = ibset(mapnow,ib)
87            continue
              mapfb(irep) = ior(mapfb(irep),mapnow)
86          continue
80        continue
81        continue
c
c  Slide down, reduce nfb(ivx).  This lets us count up from 1 for each new bar.
c  Remember, makeabar is called 1/bar, and it calls findbeam once per voice.
c
          if (nfbbar .gt. 0) then
            nfb(ivx) = nfb(ivx)-nfbbar
            do 82 ifb = 1 , nfb(ivx)
              t1fb(ivx,ifb) = t1fb(ivx,ifb+nfbbar)
              t2fb(ivx,ifb) = t2fb(ivx,ifb+nfbbar)
              ulfbq(ivx,ifb) = ulfbq(ivx,ifb+nfbbar)
82          continue
          end if
        end if
        ifb = 0
c
c  Done with forced beam masks for this bar and voice.  Now get normal beams.
c
        call findbeam(ibmrep,numbms,mapfb)
20    continue
      return
      end
      subroutine 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 /comlast/ islast
      logical islast
      common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
     *    inhead
      common /cominbot/ inbothd
      character*127 notexq
      character*60 instrq,titleq,compoq
      parameter (nm=12)
      character*1 sq,sepsymq(nm),chax
      logical headlog,vshrink
      notexq = sq//'znotes'
      lenline = 7
      do 22 iv = 1 , nv-1
        notexq = notexq(1:lenline)//sepsymq(iv)
        lenline = lenline+1
22    continue
      notexq = notexq(1:lenline)//sq//'zcharnote{'
      lenline = lenline+11
      if (.not.headlog) then
        inhead = inhnoh
      end if
      if (vshrink) then
        inhead = 16
      end if
      ndig = int(alog10(inhead+.01))+1
      write(notexq(lenline+1:lenline+ndig+10),'(i'//chax(48+ndig)//
     *    ',a10)')inhead,'}{'//sq//'titles{'
      lenline = lenline+ndig+10
c
c  Vertical skip at top of page (\Il) = etatop*glueil.  Needed whether
c    headers are present or not.
c
      glueil = xnsttop/etatop
      vskil = etatop*glueil
      if (vshrink) vskil = 2
      call writflot(vskil,notexq,lenline)
      if (.not.headlog) then
        if (islast) write(11,'(a)')notexq(1:lenline)
     *     //'}{}{0}{}{0}{}{0}}'//sq//'en%'
      else
        notexq = notexq(1:lenline)//'}{'
        lenline = lenline+2
        lcq = lenstr(instrq,60)
        if (lcq .gt. 0) then
          xitil = etait*glueil
          if (vshrink) xitil = 2
          notexq = notexq(1:lenline)//instrq(1:lcq)//'}{'
c
c Null out instrument once used
c
          instrq = ' '
          lenline = lenline+lcq+2
          call writflot(xitil,notexq,lenline)
        else
          notexq = notexq(1:lenline)//'}{0'
          lenline = lenline+3
        end if
        if (islast) write(11,'(a)')notexq(1:lenline)//'}%'
        notexq = '{'
        lenline = 1
        lcq = lenstr(titleq,60)
        if (lcq .gt. 0) then
          notexq = notexq(1:lenline)//titleq(1:lcq)
          lenline = lenline+lcq
        else
          call printl(' ')
          call printl('WARNING')
          call printl(
     *      '  In a title block, you have specified instrument and/or')
          call printl(
     *      '  composer but no title for the piece.')
        end if
        notexq = notexq(1:lenline)//'}{'
        lenline = lenline+2
        xtcil = etatc*glueil
        lcq = lenstr(compoq,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
c
c  Null out compoq so it does not get written later
c
          compoq = ' '
          xcsil = etacs1*glueil
          if (vshrink) xcsil = 2
          call writflot(xcsil,notexq,lenline)
        else
          notexq = notexq(1:lenline)//'}{0'
          lenline = lenline+3
        end if
        if (islast) write(11,'(a)')notexq(1:lenline)//'}}'//sq//'en%'
        headlog = .false.
      end if
      return
      end
      subroutine getnote(loop)
      parameter (nm=12,mv=24576)
      common /comlast/ islast
      logical islast
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      character*6 figq
      character*1 ulq,sepsymq,sq,rptfq1,rptfq2,clefq,chax
      logical beamon,firstgulp,figbass,figcheck,isfig
      character*60 instrq,titleq,compoq,cheadq
      integer*2 mmidi
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
      common /combjmp/ ivbjmp,isbjmp
      common /comtitl/ instrq,titleq,compoq,headlog,inskip,ncskip,
     *    inhead
      common /cominbot/ inbothd
      common /comfig/ itfig(74),figq(74),nfigs
      common /comnotes/ nnodur,lastlev,ndlev(nm,2),shifton,setis,notcrd,
     *       npreslur,was2(nm),ninow,nobar1
      common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,
     *       movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
     *       rptprev,rptfq1,rptfq2
      common /comhead/ ihdht,lower,headrq,lowerq,ihdvrt
      common /comfb/ nfb(nm),t1fb(nm,20),t2fb(nm,20),ulfbq(nm,20),ifb
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),aftshft,
     *                nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
     *                noffseg,ngrace,nvolt,ivlit(52),iplit(52),nlit,
     *                lenlit(52),multg(37),upg(37),slurg(37),slashg(37),
     *                naccg(74),voltxtq(6),litq(52)
      logical upg,slurg,slashg,fbon,ornrpt,shifton,setis,notcrd,isbjmp,
     *        was2,nobar1,quoted
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      character*128 litq
      common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
     *               ndotmv(nm),updot(nm,20),rtdot(nm,20)
      common /combc/ bcspec
      common /comas3/ ask(1400),iask,topmods
c
c  nvmx is either 1 or 2.  ivmx(iv,1)=iv, ; ivmx(iv,2)>nv if defined
c  ivx is current ivmx, and is the index for all notes, acc's etc.
c
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
     *                flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
     *                rtshfac
      common /comtrans/ ntrans,cheadq
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,idsig,
     *   lnam(nm),inameq(nm)
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
      common /comask/ bar1syst,fixednew,scaldold,
     *                wheadpt,fbar,poenom
      common /comslur/ listslur,upslur(nm,2),ndxslur
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
      common /comdyn/ ndyn,idyndat(99)
      common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
     *                 ic1mac(20),ilmac,iplmac
      logical mrecord,mplay,endmac,lowdot,rename,bar1syst,upslur
      character*128 lineq,lnholdq
      character*80 headrq, lowerq
      character*79 inameq
      character*59 hdlndq
      character*10 voltxtq
      character*1 charq,dotq,durq,ulfbq,dumq
      logical loop,lastchar,lower,rptnd1,rptprev,bcspec,moved,
     *        topmods,headlog,btest,sluron
1     call getchar(lineq,iccount,charq)
      if (lastchar) return
      if (charq .eq. ' ') go to 1
      if (charq .eq. '%') then
c
c  Check for a bar number format:
c
        if (iccount.eq.1 .and. lineq(2:2).eq.' ' .and.
     *      index('bB1234567890',lineq(3:3)).gt.0) then
          if (islast) write(11,'(a)')lineq(1:lenstr(lineq,128))
        end if
        iccount = 128
        go to 1
      end if
c
c  Closing repeat iff charq='/' and the prev. char was 'R' with 'd' or 'r'
c
      if (rptprev) then
        rptnd1 = charq .eq. '/'
        rptprev = .false.
      end if
c
c  Repeat at end of a piece
c
      if ((ichar(charq).ge.97.and.ichar(charq).le.103) .or.
     *       charq.eq.'r') then
c
c  This is a note/rest.  
c
        idotform = 0
        numnum = 0
c
c  If start of line of music, set pitch from previous
c
        if (ivx .le. nv) then
          kv = 1
        else
          kv = 2
        end if
        if (nnl(ivx).eq.0) lastlev = ndlev(iv,kv)
c
c  notcrd is used to tell if orn. goes on main note or chord note
c
        notcrd = .true.
c
c  Increase note count, then loop 'til blank. Label 28 is for dotted shortcuts.
c
28      nnl(ivx) = nnl(ivx)+1
        if (ornrpt) then
c
c  Replicate ornament bits, also bit 23 for beam handling if chord.
c
          iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),iornq(ivx,0))
          if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then
c
c  This is a trill (bit 7 or 15) so must dup the parameters
c
            ntrill = ntrill + 1
            ivtrill(ntrill) = ivx
            iptrill(ntrill) = nnl(ivx)
            xnsktr(ntrill) = xnsktr(ntrill-1)
          end if
        end if
        if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30)
        dotq = 'x'
        if (charq.eq.'r')
     *      irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0)
        if (btest(irest(ivx,nnl(ivx)),0)) then
c
c  Rest stuff.  First check if previous note was full-bar-pause
c
          if (lineq(iccount+1:iccount+1) .eq.' '
     *                    .and. nnl(ivx).gt.1) then
            if (btest(islur(ivx,nnl(ivx)-1),19))
     *          islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19)
          end if
c
c  Set default rest level at 0 unless 2 voices/staff in which case it's -4 or 2
c  for voice a or b.  Set a-types at 0 as encountered and adjust later
c  after '//'.  (Override heights will be set to 100+offset)
c
          if (ivx .le. nv) then
            nolev(ivx,nnl(ivx)) = 0
          else
            nolev(ivx,nnl(ivx)) = 2
          end if
        end if
2       call getchar(lineq,iccount,durq)
        ic = ichar(durq)
        if (ic.le.57 .and. ic.ge.48) then
c
c  Digit
c
          if (numnum .eq. 0) then
            nnodur = ic-48
            numnum = 1
            go to 2
          else if (numnum .eq. 1) then
            ioct = ic-48
            numnum = 2
            go to 2
          else
            print*,'>2 digits in note sym., ivx,nn:',ivx,nnl(ivx)
            stop
          end if
        else if (durq .eq. 'd') then
          dotq = durq
          if (lineq(iccount+1:iccount+1) .eq. 'd') then
c
c  Double dot.
c
            iccount = iccount+1
            islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),3)
          end if
          if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
c
c  move a dot, unless next char is not part of a number
c
            if (index('0123456789.',lineq(iccount+2:iccount+2)) .eq. 0)
     *         go to 2
            irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),19)
            call getchar(lineq,iccount,durq)
            ndotmv(ivx) = ndotmv(ivx)+1
            iccount=iccount+1
            call readnum(lineq,iccount,dumq,updot(ivx,ndotmv(ivx)))
            if (durq .eq. '-')
     *         updot(ivx,ndotmv(ivx)) = -updot(ivx,ndotmv(ivx))
            if (index('+-',dumq) .gt. 0) then
c
c  Vertical shift also
c
              iccount=iccount+1
              call readnum(lineq,iccount,durq,rtdot(ivx,ndotmv(ivx)))
              if (dumq .eq. '-')
     *         rtdot(ivx,ndotmv(ivx)) = -rtdot(ivx,ndotmv(ivx))
            else
              rtdot(ivx,ndotmv(ivx)) = 0.
            end if
            iccount = iccount-1
          end if
          go to 2
        else if (durq .eq. 'p') then
c
c  Full-bar rest as pause
c
          islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),19)
          go to 2
        else if (durq .eq. 'b') then
c
c  Blank rest
c
          islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),29)
          go to 2
        else if (index('fsn',durq) .gt. 0) then
c
c  Accidental
c
          if (nacc(ivx,nnl(ivx)) .eq. 0) then
c
c  No accidental has been set yet
c
            nacc(ivx,nnl(ivx)) = index('fsn',durq)
          else
c
c  Repeated accid, so must be double
c
            nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2)
          end if
          go to 2
        else if (index('+-<>',durq) .gt. 0) then
          ipm = index('- +',durq)-2
          if (.not.btest(irest(ivx,nnl(ivx)),0)) then
c
c  A note, not a rest.
c
            call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved)
            if (moved) go to 2
c
c  Octave jump with a note
c
            if (numnum .lt. 2) then
              lastlev = lastlev+ipm*7
            else
              ioct = ioct+ipm*1
            end if
            go to 2
          else
c
c  Override default height of a rest
c
c            call getchar(lineq,iccount,durq)
            iccount = iccount+1
            call readnum(lineq,iccount,durq,fnum)
            if (lineq(iccount-1:iccount-1) .eq. '.') then
c
c  Kluge in case there is a shortcut ".". It will have been sucked up by
c  readnum.  (Same doesn't hold for ",")
c
               iccount = iccount-2
               go to 2
            end if
            nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum)
c
c  There may be more characters for this rest
c
            iccount = iccount-1
            go to 2
          end if
        else if (durq .eq. 'x') then
c
c  xtuplet: Set all durations to 0 except last one.  Set flag on this note.
c
          irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),28)
c
c  Next input will be digit
c
          iccount = iccount+1
          call readnum(lineq,iccount,durq,fnum)
          ntup = nint(fnum)
c
c  Only other possibilities here are ' ' or 'n'
c
          if (durq .eq. 'n') then
c
c  Alter xtup number
c
            if (lineq(iccount+1:iccount+1) .eq. ' ') then
c
c  If the only modifier is 'n', cancel the number
c
              islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),31)
            else
              numshft = 0
30            call getchar(lineq,iccount,durq)
              if (durq .eq. 'f') then
c
c  Flip up-down-ness
c
                irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),14)
                go to 30
              else if (durq .ne. ' ') then
c
c  Vertical or horiz shift; durq must be +/-
c
                numshft = numshft+1
                iofforn = 1
                if (durq .eq. '-') iofforn = -1
                iccount = iccount+1
                call readnum(lineq,iccount,durq,xofforn)
                iccount = iccount-1
                if (numshft .eq. 1) then
c
c  Vertical shift
c
                  iofforn = iofforn*nint(xofforn) + 16
c
c  Turn on bit 1; set bits 2-6 to iofforn
c
                  irest(ivx,nnl(ivx)) =
     *               ior(irest(ivx,nnl(ivx)),2+4*iofforn)
                else
c
c  Horizontal shift
c
                  iofforn = iofforn*nint(xofforn*10)+16
                  irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),7)
                  irest(ivx,nnl(ivx)) =
     *               ior(irest(ivx,nnl(ivx)),ishft(iofforn,9))
                end if
                go to 30
              end if
            end if
          end if
c
c  Set note level of 1st note of xtup, provided not a rest
c
          if (.not.btest(irest(ivx,nnl(ivx)),0)) then
            if (numnum .eq. 2) then
              lastlev = ifnolev(charq,ioct)
              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
          do 40 npreslur = npreslur , 1 , -1
c
c  Set note level for preslur on starting note of xtuplet
c
            call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev)
40        continue
          numnum = 0
          nodur(ivx,nnl(ivx)) = 0
          do 6 itup = 2 , ntup
            if (ornrpt) then
              iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),
     *           iand(iornq(ivx,nnl(ivx)-1),10026991))
              if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then
c
c  This is a trill (bit 7 or 15) so must dup the parameters
c
                ntrill = ntrill + 1
                ivtrill(ntrill) = ivx
                iptrill(ntrill) = nnl(ivx)
                xnsktr(ntrill) = xnsktr(ntrill-1)
              end if
            end if
            nnl(ivx) = nnl(ivx)+1
            if (fbon) ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),30)
7           call getchar(lineq,iccount,charq)
            if (charq .eq. ' ') then
              go to 7
            else if (charq .eq. 'o') then
c
c  Ornament in xtuplet.  "o" symbol must come AFTER the affected note
c
              if (notcrd) then
                nole = nolev(ivx,nnl(ivx)-1)
              else
                nole = iand(127,ishft(icrdat(ncrd),-12))
              end if
              call getorn(lineq,iccount,iornq(ivx,nnl(ivx)-1),
     *             iornq(ivx,0),ornrpt,noffseg,
     *             nnl(ivx)-1,ivx,.false.,notcrd,nole)
              go to 7
            else if (index('st()',charq) .gt. 0) then
              nnlivx = nnl(ivx)-1
              if (charq .eq. '(') then
c
c  Detected preslur in xtuplet loop, non-chord note
c
                nnlivx = nnlivx+1
                npreslur = npreslur+1
              end if
              islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0)
              if (charq.eq.'t') islur(ivx,nnlivx) =
     *                    ibset(islur(ivx,nnlivx),1)
              if (ivx .le. nv) then
                kv = 1
              else
                kv = 2
              end if
              call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,
     *                   isdat3,nsdat,notcrd,nolev(ivx,nnlivx))
              go to 7
            else if (charq .eq. sq) then
              call littex(islur,nnl(ivx),ivx,topmods,lineq,iccount)
              go to 7
            else if (index('0123456789#-nx_',charq) .gt. 0) then
c
c  Figure.  Must come AFTER the first note of xtup
c
              nfig1 = nfigs+1
              call getfig(itoff(nfig1),charq,lineq,iccount,
     *                    isfig(nnl(ivx)),itfig(nfig1),itsofar(1),
     *                    0,figq(nfig1),ivx,nfigs)
              go to 7
            else if (charq .eq. 'X') then
              call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx)-1)),
     *         shifton,wheadpt,iornq(ivx,nnl(ivx)),ivx,
     *         irest(ivx,nnl(ivx)),itsofar(ivx),ntup,itup,nnodur,dotq)
              go to 7
            else if (charq .eq. 'z') then
c
c  Chord note in xtup.  Goes with *prior* note.
c
              notcrd = .false.
              ncrd = ncrd+1
              ipl(ivx,nnl(ivx)-1) = ibset(ipl(ivx,nnl(ivx)-1),10)
              numnum = 0
              icrdat(ncrd) = ior(nnl(ivx)-1,ishft(ivx,8))
              icrdorn(ncrd) = 0
c
c  Get note name
c
              call getchar(lineq,iccount,charq)
c
c  Get optional inputs
c
34            call getchar(lineq,iccount,durq)
c
c  When chord note is done, will get ' ', making ndx=0, so go past this block
c
              ndx = index('fsn+-<>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 (ndx .le. 7) then
c
c +/-/</> Check whether octave or accidental shift
c
                  nactmp = 0
                  call chkpm4ac(lineq,iccount,nactmp,moved)
                  if (moved) then
c
c  Transfer accidental shift values
c
                    call setbits(icrdot(ncrd),6,14,
     *                              igetbits(nactmp,6,4))
                    call setbits(icrdot(ncrd),7,20,
     *                              igetbits(nactmp,7,10))
                  else
                    if (durq .eq. '+') then
                      lastlev = lastlev+7
                    else if (durq .eq. '-') then
                      lastlev = lastlev-7
                    end if
                  end if
                else if (durq .eq. 'e') then
                  icrdat(ncrd) = ibset(icrdat(ncrd),23)
                  irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
                else if (durq .eq. 'r') then
                  icrdat(ncrd) = ibset(icrdat(ncrd),24)
                  irest(ivx,nnl(ivx)-1) =
     *                      ibset(irest(ivx,nnl(ivx)-1),20)
                else
c
c must be a number, save it in ioct
c
                  numnum = 1
                  ioct = ndx-5
                end if
                go to 34
              end if
              if (numnum .eq. 1) then
                lastlev = ifnolev(charq,ioct)
              else
                lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7)
              end if
              icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12))
              do 41 npreslur = npreslur , 1 , -1
c
c  Set note level for preslur on chord note in xtup
c
                call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev)
c
c  Following lines copied from loop for non-xtup, chord note, preslur
c  Initially I assigned the slur(s) to next note, so fix.
c
                islur(ivx,nnl(ivx)) = ibclr(islur(ivx,nnl(ivx)),0)
                islur(ivx,nnl(ivx)-1) = ibset(islur(ivx,nnl(ivx)-1),0)
                isdat2(nsdat-npreslur+1) = 
     *                               ibset(isdat2(nsdat-npreslur+1),0)
                call setbits(isdat1(nsdat-npreslur+1),8,3,
     *               igetbits(isdat1(nsdat-npreslur+1),8,3)-1)
41            continue
              go to 7
            end if
c
c  End of loop for xtup options. If here, charq must be a (non-crd) note name.
c  or rest
c
            if (charq .eq. 'r') then
              irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),0)
              if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
c
c  Override height of embedded xtup rest
c
                call getchar(lineq,iccount,durq)
                ipm = index('- +',durq)-2
                iccount = iccount+1
                call readnum(lineq,iccount,durq,fnum)
                nolev(ivx,nnl(ivx)) = 100+ipm*nint(fnum)
                iccount = iccount-1
              else if (ivx .le. nv) then
                nolev(ivx,nnl(ivx)) = 0
              else
                nolev(ivx,nnl(ivx)) = 2
              end if
            end if
            notcrd = .true.
8           call getchar(lineq,iccount,durq)
            if (durq .ne. ' ') then
              if (index('+-<>',durq) .gt. 0) then
c
c  Accidental horizontal shift
c
                call chkpm4ac(lineq,iccount,nacc(ivx,nnl(ivx)),moved)
                if (.not.moved) then
                  if (durq.eq.'+') then
                    lastlev = lastlev+7
                  else if (durq.eq.'-') then
                    lastlev = lastlev-7
                  end if
                end if
              else if (index('fsn',durq) .gt. 0) then
                if (nacc(ivx,nnl(ivx)) .eq. 0) then
c
c  No accid set yet
c
                  nacc(ivx,nnl(ivx)) = index('fsn',durq)
                else
c
c  Symbol must be repeated, so it's a double
c
                  nacc(ivx,nnl(ivx)) = ibset(nacc(ivx,nnl(ivx)),2)
                end if
              else if (index('ul',durq) .gt. 0) then
c
c  Force stem direction for non-beamed xtup note
c
                islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30)
                if (durq .eq. 'u') islur(ivx,nnl(ivx)) =
     *                ibset(islur(ivx,nnl(ivx)),17)
              else if (durq .eq. 'e') then
c
c  Left-shift main xtup note
c
                ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8)
                irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
              else if (durq .eq. 'r') then
c
c  Right-shift main xtup note
c
                ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9)
                irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20)
              else
c
c  Must be an octave number
c
                lastlev = ifnolev(charq,ichar(durq)-48)
              end if
              go to 8
            end if
            if (itup .lt. ntup) then
c
c  Last note is handled *after* flowing out of the xtup if block, but still
c    within block for a note-rest.  Set note level now (rest already done)
c
              if (.not.btest(irest(ivx,nnl(ivx)),0)) then
                lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7)
                nolev(ivx,nnl(ivx)) = lastlev
              end if
              nodur(ivx,nnl(ivx)) = 0
              do 42 npreslur = npreslur , 1 , -1
c
c  Set note level for preslur on internal xtup note
c
                call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev)
42            continue
            end if
6         continue
          if (ornrpt) then
            iornq(ivx,nnl(ivx)) = ior(iornq(ivx,nnl(ivx)),
     *           iand(iornq(ivx,nnl(ivx)-1),10026991))
            if (iand(iornq(ivx,nnl(ivx)),32896) .gt. 0) then
c
c  This is a trill (bit 7 or 15) so must dup the parameters
c
              ntrill = ntrill + 1
              ivtrill(ntrill) = ivx
              iptrill(ntrill) = nnl(ivx)
              xnsktr(ntrill) = xnsktr(ntrill-1)
            end if
          end if
c
c  End of if-block for xtuplet input
c
        else if (durq .eq. 'm') then
c
c  Multi-bar rest: next 1 or two digits are # of bars.
c  For some purposes, pretend its one bar only
c
          nodur(ivx,nnl(ivx)) = lenbar
          ibarmbr = nbars+1
          mbrest = 0
          xb4mbr = 0.
20        call getchar(lineq,iccount,durq)
          if (ichar(durq).ge.48.and.ichar(durq).le.57) then
            mbrest = 10*mbrest+ichar(durq)-48
            go to 20
          end if
        else if (index('ul',durq) .gt. 0) then
c
c  Set stem flipper
c
          islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),30)
          if (durq .eq. 'u') islur(ivx,nnl(ivx)) =
     *                ibset(islur(ivx,nnl(ivx)),17)
          go to 2
        else if (durq .eq. 'a') then
c
c  "Alone", i.e., prohibit beam
c
          islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),18)
          go to 2
        else if (durq .eq. 'r') then
c
c  Right offset by one notehead
c
          ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),9)
          irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20)
          go to 2
        else if (durq .eq. 'e') then
c
c  Left offset by one notehead
c
          ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),8)
          irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
          go to 2
        else if (durq .eq. ',') then
c
c  2:1 pattern
c
          idotform = 3
c
c  Now flow to duration setting, as if durq=' '
c
        else if (durq .eq. '.') then
c
c  Dotted pattern.  Close out note.  Mult time by 3/4.
c  Set time for next note to 1/4.  Start the note.
c
          idotform = 1
        else if (durq .eq. 'o') then
c
c  Suppress rest centering
c
          irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),25)
          go to 2
        else if (durq .ne. ' ') then
          print*,'Illegal character in note: ',durq,', ivx,nn:',
     *        ivx,nnl(ivx)
          stop
        end if
c
c  Done with note/rest options.  Set level and duration.
c
        if (.not.btest(irest(ivx,nnl(ivx)),0)) then
          if (numnum .eq. 2) then
            lastlev = ifnolev(charq,ioct)
            nolev(ivx,nnl(ivx)) = lastlev
          else
            lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7)
            nolev(ivx,nnl(ivx)) = lastlev
          end if
          do 43 npreslur = npreslur , 1 , -1
c
c  Set level for preslur on normal note, non-chord
c
            call setbits(isdat2(nsdat-npreslur+1),7,19,lastlev)
43        continue
        end if
        if (idotform .gt. 0) then
          if (idotform .eq. 1) then
            nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)*3/2
          else if (idotform .eq. 2) then
            nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/3
          else if (idotform .eq. 3) then
            nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)
          else if (idotform .eq. 4) then
            nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx)-1)/2
          end if
        else if (btest(islur(ivx,nnl(ivx)),19)) then
c
c  Set duration of full-bar rest as pause
c
          nodur(ivx,nnl(ivx)) = lenbar
c
c  Use a one-line function to set nnodur.  It gives inverse of ifnodur.
c
          nnodur = index('62514x0x37',
     *                   chax(48+int(log(.1+lenbar)/.69315)))-1
        else if (ibarmbr.ne.nbars+1) then
          nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)
          if (btest(islur(ivx,nnl(ivx)),3))
     *      nodur(ivx,nnl(ivx)) = nodur(ivx,nnl(ivx))*7/6
        end if
        if (shifton .and. .not.btest(irest(ivx,nnl(ivx)),16)) then
c
c  Shift is on, and this is not first shifted note.  Check for duration change
c
          if (nodur(ivx,nnl(ivx)) .ne. nodur(ivx,nnl(ivx)-1)) then
c
c  Must stop and restart the offset.
c
            irest(ivx,nnl(ivx)-1) = ibset(irest(ivx,nnl(ivx)-1),17)
            irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),16)
            nudoff(ivx) = nudoff(ivx)+1
            udoff(ivx,nudoff(ivx)) = udoff(ivx,nudoff(ivx)-1)
          end if
        end if
        itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
        if (mod(itsofar(ivx)-lenb0,lenbar) .eq. 0) then
c
c  Finished a bar
c
          nbars = nbars+1
          nib(ivx,nbars) = nnl(ivx)
          if (firstgulp.and.lenb0.ne.0.and.nbars.eq.1) then
c
c  Just finished the pickup bar for this voice.
c
            lenbar = lenb1
          end if
        end if
        if (idotform .eq. 1) then
          call getchar(lineq,iccount,charq)
          idotform = 2
          numnum = 1
          go to 28
        else if (idotform .eq. 3) then
          call getchar(lineq,iccount,charq)
          idotform = 4
          numnum = 1
          go to 28
        end if
c
c  End of sub block for note-rest
c
      else if (charq .eq. 'z') then
c
c  Chord note.  Must have note name, may have octave#,+,-,s,f,n,d
c  Actually the 'd' is not used, since time value comes from
c    basic note. Unless dot is to be shifted!
c  Doesn't increase # of notes, so must handle separately
c  ncrd: index of crd
c  Set bit 10 of ipl on main note as flag
c  Bits in icrdat:
c     0-7   ip within voice
c     8-11  ivx
c     12-18 note level
c     19    accidental?
c     20-22 accidental value (1=natural, 2=flat, 3=sharp, 6=dflat, 7=dsharp)
c     23    shift left
c     24    shift right
c     25    arpeggio start or stop
c     26    flag for moved dot (here, not icrdot, since this is always reset!)
c
c  Bits in icrdot:
c     0-6   10*abs(vertical dot shift in \internote) + 64
c     7-13  10*abs(horizontal dot shift in \internote) + 64
c     14-19 vert accidental shift-32
c     20-26 10*(horiz accidental shift-3.2)
c
c  Bits in icrdorn are same as in iornq, even tho most orns won't go in crds.
c
        ncrd = ncrd+1
        ipl(ivx,nnl(ivx)) = ibset(ipl(ivx,nnl(ivx)),10)
        numnum = 0
        icrdat(ncrd) = ior(nnl(ivx),ishft(ivx,8))
        icrdot(ncrd) = 0
        icrdorn(ncrd) = 0
c
c  Get note name
c
        call getchar(lineq,iccount,charq)
c
c  Get optional inputs
c
25      call getchar(lineq,iccount,durq)
        ndx = index('fsn+-<>12345678red',durq)
        if (ndx .gt. 0) then
          if (ndx .le. 3) then
            if (.not.btest(icrdat(ncrd),19)) then
              icrdat(ncrd) = ibset(icrdat(ncrd),19)
              icrdat(ncrd) = ior(icrdat(ncrd),ishft(ndx,20))
            else
              icrdat(ncrd) = ibset(icrdat(ncrd),22)
            end if
          else if (ndx .le. 7) then
c
c +/-/</> Check whether octave or accidental shift
c
            nactmp = 0
            call chkpm4ac(lineq,iccount,nactmp,moved)
            if (moved) then
c
c  Transfer accidental shift values
c
              call setbits(icrdot(ncrd),6,14,igetbits(nactmp,6,4))
              call setbits(icrdot(ncrd),7,20,igetbits(nactmp,7,10))
            else
              if (durq .eq. '+') then
                lastlev = lastlev+7
              else if (durq .eq. '-') then
                lastlev = lastlev-7
              end if
            end if
          else if (durq .eq. 'e') then
            icrdat(ncrd) = ibset(icrdat(ncrd),23)
            irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),27)
          else if (durq .eq. 'r') then
            icrdat(ncrd) = ibset(icrdat(ncrd),24)
            irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),20)
          else if (durq .eq. 'd') then
c
c  Must keep 'd' optional (backward compatibility), unless it is moved!
c
            if (index('+-',lineq(iccount+1:iccount+1)) .gt. 0) then
c
c  move a dot, unless next char is not part of a number
c
              if (index('0123456789.',lineq(iccount+2:iccount+2))
     *              .eq. 0) go to 25
              icrdat(ncrd) = ibset(icrdat(ncrd),26)
              call getchar(lineq,iccount,durq)
              iccount=iccount+1
              call readnum(lineq,iccount,dumq,fnum)
              if (durq .eq. '+') then
                icrdot(ncrd) = ior(icrdot(ncrd),nint(fnum*10)+64)
              else
                icrdot(ncrd) = ior(icrdot(ncrd),-nint(fnum*10)+64)
              end if
              if (index('+-',dumq) .gt. 0) then
c
c  Vertical shift specified also
c
                iccount=iccount+1
                call readnum(lineq,iccount,durq,fnum)
                if (dumq .eq. '+') then
                  ifnum = nint(fnum*10)+64
                else
                  ifnum = -nint(fnum*10)+64
                end if
              else
                ifnum = 64
              end if
              icrdot(ncrd) = ior(icrdot(ncrd),ishft(ifnum,7))
              iccount = iccount-1
            end if
          else
c
c must be a single digit, save it in ioct
c
            numnum = 1
            ioct = ndx-7
          end if
          go to 25
        end if
        if (numnum .eq. 1) then
          lastlev = ifnolev(charq,ioct)
        else
          lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7)
        end if
        icrdat(ncrd) = ior(icrdat(ncrd),ishft(lastlev,12))
        do 44 npreslur = npreslur , 1 , -1
          call setbits (isdat2(nsdat-npreslur+1),7,19,lastlev)
c
c  Set level for chord note.
c  Initially I assigned the slur(s) to next note, so fix.
c
          islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),0)
          islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),0)
          isdat2(nsdat-npreslur+1) = ibset(isdat2(nsdat-npreslur+1),0)
          call setbits(isdat1(nsdat-npreslur+1),8,3,
     *               igetbits(isdat1(nsdat-npreslur+1),8,3)-1)
44      continue
        if (notcrd) then
c
c  This is the first chord note in this chord.
c
          minlev = min(nolev(ivx,nnl(ivx)),lastlev)
          maxlev = max(nolev(ivx,nnl(ivx)),lastlev)
        else
          minlev = min(minlev,lastlev)
          maxlev = max(maxlev,lastlev)
        end if
        notcrd = .false.
      else if (charq .eq. 'G') then
c
c Grace, comes *before* main note:
c UNLESS there's an 'A' or 'W' after the 'G'
c   ngrace = # of grace note groups so far in block
c   ivg(ngrace), ipg(ngrace)
c   nng(ngrace) = # of notes in this group: default = 1
c   ngstrt(ngrace) = starting position in nolevg of levels for this grace
c   multg(ngrace) = multiplicity: default = 1;  input as 'm(digit)'
c   upg(ngrace) = logical for beam or stem dirn: default T, input'u,l'
c   slurg(ngrace) = logical for slur; default F, input 's'
c   slashg(ngrace) = T if slash; default is F, input 'x'
c These data MUST precede note name of first note
c   nolevg, naccg: lists of levels and accid's, indexed as described above.
c
        ngrace = ngrace+1
        ivg(ngrace) = ivx
        ipg(ngrace) = nnl(ivx)+1
        if (ngrace .eq. 1) then
          ngstrt(ngrace) = 1
        else
          ngstrt(ngrace) = ngstrt(ngrace-1)+nng(ngrace-1)
        end if
        islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),4)
        nng(ngrace) = 1
        multg(ngrace) = 1
        upg(ngrace) = .true.
        slurg(ngrace) = .false.
        slashg(ngrace) = .false.
18      call getchar(lineq,iccount,charq)
        if (index('WA',charq) .gt. 0) then
c
c  Grace is on note that was already done, so shift flags forward one note.
c  This puts flag on actual note with grace; later for W will go ahead one more.
c
          ipg(ngrace) = nnl(ivx)
          islur(ivx,nnl(ivx)+1) = ibclr(islur(ivx,nnl(ivx)+1),4)
          islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),4)
          if (slurg(ngrace))
     *        iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),24)
          if (charq .eq. 'A') then
c
c  close After, clear way-after bit, to ensure priority of most recent A/W
c
            ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),31),29)
          else
c
c  Way after; later assign to following note, and position like normal grace.
c
            ipl(ivx,nnl(ivx)) = ibset(ibclr(ipl(ivx,nnl(ivx)),29),31)
          end if
        else if (charq .eq. 'm') then
          call getchar(lineq,iccount,charq)
          multg(ngrace) = ichar(charq)-48
        else if (index('123456789',charq) .gt. 0) then
          call readnum(lineq,iccount,durq,fnum)
          iccount = iccount-1
          nng(ngrace) = nint(fnum)
        else if (charq .eq. 'l') then
          upg(ngrace) = .false.
        else if (charq .eq. 's') then
          slurg(ngrace) = .true.
          if (nnl(ivx) .gt. 0) then
c
c  If A- or W-grace, set signal to start slur on main note.
c
            if(btest(ipl(ivx,nnl(ivx)),31) .or.
     *                 btest(ipl(ivx,nnl(ivx)),29))
     *         iornq(ivx,nnl(ivx))=ibset(iornq(ivx,nnl(ivx)),24)
          end if
        else if (charq .eq. 'x') then
          slashg(ngrace) = .true.
        else if (charq .eq. 'u') then
        end if
        if (index('abcdefg',charq) .eq. 0) go to 18
c
c  At this point, charq is first note name in grace
c
        do 19 ing = ngstrt(ngrace), ngstrt(ngrace)+nng(ngrace)-1
          naccg(ing) = 0
          ioct = 0
          if (ing .gt. ngstrt(ngrace)) then
55          call getchar(lineq,iccount,charq)
            if (charq .eq. ' ') go to 55
          endif
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 (naccg(ing) .eq. 0) then
                naccg(ing) = index('fsn',durq)
              else
c
c  Double accidental
c
                naccg(ing) = ibset(naccg(ing),2)
              end if
            else
              ioct = ichar(durq)-48
            end if
            go to 9
          end if
          if (ioct .gt. 0) then
            lastlev = ifnolev(charq,ioct)
          else
            if (nnl(ivx).eq.0 .and. ing.eq.ngstrt(ngrace)) then
              if (ivx .le. nv) then
                kv = 1
              else
                kv = 2
              end if
              lastlev = ndlev(iv,kv)
            end if
            lastlev = lastlev-3+mod(ifnolev(charq,10)-lastlev+3,7)
          end if
          nolevg(ing) = lastlev
19      continue
c
c  Grace could come before first note of block, so reset end level.
c
        if (nnl(ivx).eq.0) then
          if (ivx .le. nv) then
            kv = 1
          else
            kv = 2
          end if
          ndlev(iv,kv) = lastlev
        end if
      else if (charq .eq. sq) then
c
c  Literal TeX string
c
        call littex(islur,nnl(ivx)+1,ivx,topmods,lineq,iccount)
      else if (charq .eq. 'o') then
c
c  Ornament on non-xtup note.  Symbol must come AFTER the affected note
c
        if (notcrd) then
          nole = nolev(ivx,nnl(ivx))
        else
          nole = iand(127,ishft(icrdat(ncrd),-12))
        end if
        call getorn(lineq,iccount,iornq(ivx,nnl(ivx)),
     *       iornq(ivx,0),ornrpt,noffseg,nnl(ivx),ivx,
     *      .true.,notcrd,nole)
      else if (index('st()',charq) .gt. 0) then
        nnlivx = nnl(ivx)
        if (charq .eq. '(') then
c
c Detect preslur on normal non-chord note
c
          nnlivx = nnlivx+1
          npreslur = npreslur+1
        end if
        islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),0)
        if (charq.eq.'t')
     *    islur(ivx,nnlivx) = ibset(islur(ivx,nnlivx),1)
        if (ivx .le. nv) then
          kv = 1
        else
          kv = 2
        end if
        call sslur(lineq,iccount,iv,kv,nnlivx,isdat1,isdat2,isdat3,
     *             nsdat,notcrd,nolev(ivx,nnlivx))
      else if (charq .eq. '?') then
c
c  Arpeggio
c
        if (btest(ipl(ivx,nnl(ivx)),10)) then
c
c  This is a chordal note.  Set a bit in icrdat.  But if *main* (spacing) note
c  of chord, will not set icrdat(25), but iornq(27)
c
          icrdat(ncrd) = ibset(icrdat(ncrd),25)
        else
          iornq(ivx,nnl(ivx)) = ibset(iornq(ivx,nnl(ivx)),27)
        end if
      else if (index('0123456789#-nx_',charq) .gt. 0) then
c
c  We have a figure.  Must come AFTER the note it goes under
c
        nfig1 = nfigs+1
        call getfig(itoff(nfig1),charq,lineq,iccount,isfig(nnl(ivx)),
     *       itfig(nfig1),itsofar(1),nodur(ivx,nnl(ivx)),figq(nfig1),
     *       ivx,nfigs)
      else if (charq .eq. '[') then
c
c  Start forced beam.  Record barno & time since start of inp. blk.  Set signal
c
        nfb(ivx) = nfb(ivx)+1
        fbon = .true.
        ulfbq(ivx,nfb(ivx)) = 'x'
        t1fb(ivx,nfb(ivx)) = itsofar(ivx)
        nadj = 0
17      call getchar(lineq,iccount,charq)
        if (index('ul',charq) .gt. 0) then
          ulfbq(ivx,nfb(ivx)) = charq
          go to 17
        else if (charq .eq. 'j') then
c
c  Continuing a jumped beam here
c
          irest(ivx,nnl(ivx)+1) = ibset(irest(ivx,nnl(ivx)+1),24)
          go to 17
        else if (charq .eq. 'h') then
          islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),2)
          go to 17
        else if (charq .eq. 'm') then
c
c  Force multiplicity.  Next input is digit
c
          call getchar(lineq,iccount,charq)
          islur(ivx,nnl(ivx)+1) = ibset(islur(ivx,nnl(ivx)+1),21)
          call setbits(islur(ivx,nnl(ivx)+1),3,22,ichar(charq)-48)
          go to 17
        else if (charq .ne. ' ') then
c
c  Must be '+/-' for height or slope shift
c
          nadj = nadj+1
c
c  nadj = 1,2, or 3 for normal start level, slope, or beam-thk start level.
c
          iccount = iccount+1
          call readnum(lineq,iccount,durq,fnum)
          iccount = iccount-1
          iadj = nint(fnum)
          if (charq .eq. '-') iadj = -iadj
          if (nadj .eq. 1) then
c
c  This is a level shift.  Note if 0 was entered, iadj = 30
c
            ipl(ivx,nnl(ivx)+1) =
     *           ior(ipl(ivx,nnl(ivx)+1),ishft(iadj+30,11))
          else if (nadj .eq. 2) then
c
c  Must be a slope shift
c
            ipl(ivx,nnl(ivx)+1) =
     *           ior(ipl(ivx,nnl(ivx)+1),ishft(iadj+30,17))
          else
c
c  Beam-thk fine tune
c
            islur(ivx,nnl(ivx)+1) =
     *           ior(islur(ivx,nnl(ivx)+1),ishft(iadj,27))
          end if
          go to 17
        end if
      else if (charq .eq. ']') then
        call getchar(lineq,iccount,charq)
        if (index('j ',charq) .gt. 0) then
c
c  Since ']' comes AFTER note, itsofar has been updated.  Set ending signal.
c
          t2fb(ivx,nfb(ivx)) = itsofar(ivx)
          fbon = .false.
          if (charq .eq. 'j') then
            irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),23)
          end if
        else if (charq .eq. '[') then
c
c  Only other possibility is "[" for multiplicity down-up signal
c
          islur(ivx,nnl(ivx)) = ibset(islur(ivx,nnl(ivx)),20)
        end if
      else if (charq .eq. 'D') then
        call getdyn(ivx,nnl(ivx),irest(ivx,nnl(ivx)),lineq,iccount)
      else if (charq .eq. 'h') then
c
c  Heading or height.  For heading, only OK if at start of block
c  Check whether at beginning of a block
c
        if (iv.ne.1 .or. nnl(1).ne.0) then
          print*,'You entered "h" not at beginning of block'
          stop
        end if
        call getchar(lineq,iccount,durq)
        ihdvrt = 0
        if (index('+-',durq) .gt. 0) then
c
c Vertical offset
c
          iccount = iccount+1
          call readnum(lineq,iccount,charq,fnum)
          ihdvrt = fnum+.1
          if (durq .eq. '-') ihdvrt = -ihdvrt
          durq = charq
        end if
        if (durq .ne. ' ') then
c
c  Height symbol.  Read past (until next blank)
c
3         call getchar(lineq,iccount,durq)
          if (durq .ne. ' ') go to 3
        else
c
c  Set flag for header & read it in
c
          ihdht = 16
          call getbuf(headrq)
          iccount = 128
        end if
      else if (charq .eq. 'L') then
c
c  Linebreak, already handled in pmxa, but check for movement break
c
        iccount = iccount+1
        call readnum(lineq,iccount,durq,fmovbrk)
        if (durq .eq. 'P') then
          iccount = iccount+1
          call readnum(lineq,iccount,durq,fnum)
        end if
        if (durq .eq. 'M') then
          movbrk = nint(fmovbrk)
          movgap = 0
          parmov = -1.
          call getchar(lineq,iccount,durq)
31        if (durq .eq. '+') then
c
c  Get vertical space (\internotes)
c
            iccount = iccount+1
            call readnum(lineq,iccount,durq,fnum)
            movgap = nint(fnum)
            go to 31
          else if (durq .eq. 'i') then
            iccount = iccount+1
            call readnum(lineq,iccount,durq,parmov)
            go to 31
          else if (durq .eq. 'c') then
            nobar1 = .true.
            call getchar(lineq,iccount,durq)
            go to 31
          else if (durq .eq. 'r') then
c
c  "rename" can be set on or off.
c
            call getchar(lineq,iccount,durq)
            rename = durq.eq.'+'
            call getchar(lineq,iccount,durq)
            go to 31
          else if (durq .eq. 'n') then
c
c  Change # of voices.  Input ninow, iiorig(1...ninow).  Will use names,
c  staves per inst. and clefs  corr. to iiorig in original list of instruments.
c
            nvold = nv
            nv = 0
            rename = .true.
            call getchar(lineq,iccount,durq)
            ninow = ichar(durq)-48
            iiv = 0
            do 63 iinow = 1 , ninow
              call getchar(lineq,iccount,durq)
              iiorig(iinow) = ichar(durq)-48
              nspern(iinow) = nsperi(iiorig(iinow))
              nv = nv+nspern(iinow)
              sepsymq(iiv+nspern(iinow)) = '&'
              if (nspern(iinow) .gt. 1) then
                do 64 iis = 1 , nspern(iinow)-1
                  sepsymq(iiv+iis) = '|'
64              continue
                iiv = iiv+nspern(iinow)
              end if
63          continue
            if (islast) write(11,'(a)')sq//'newnoi{'
     *          //chax(ninow+48)//'}%'
            if (nv.eq.1 .and. nvold.gt.1) then
              if (islast) write(11,'(a)')sq//'nostartrule'
            else if (nv.gt.1 .and. nvold.eq.1) then
              if (islast) write(11,'(a)')sq//'startrule'
            end if
            iiv = 0
            do 60 iinow = 1 , ninow
              do 61 iis = 1 , nspern(iinow)
                iiv = iiv+1
c
c  May not really need to re-enter clefs, but it's easier to program since
c  clef names are not saved but are needed in newvoice to set ncmidcc.
c
                call getchar(lineq,iccount,clefq)
                call newvoice(iiv,clefq,.true.)
                if (nspern(iinow) .eq. 1) then
                  hdlndq = chax(48+numclef(clefq))
                  lclf = 1
                else if (iis .eq. 1) then
                  hdlndq = '{'//chax(48+numclef(clefq))
                  lclf = 2
                else if (iis .lt. nspern(iinow)) then
                  hdlndq = hdlndq(1:lclf)//chax(48+numclef(clefq))
                  lclf = lclf+1
                else
                  hdlndq = hdlndq(1:lclf)//chax(48+numclef(clefq))//'}'
                  lclf = lclf+2
                end if
61            continue
c
c  setstaffs & setclef go by instrument, not voice
c
              if (islast) then
                if (iinow .lt. 10) then
                  write(11,'(a)')sq//'setstaffs'
     *              //chax(48+iinow)//chax(48+nspern(iinow))//'%'
                  write(11,'(a)')sq//'setclef'//chax(48+iinow)
     *              //hdlndq(1:lclf)//'%'
                else
                  write(11,'(a11,i2,a)')sq//'setstaffs{',iinow,
     *                 '}'//chax(48+nspern(iinow))//'%'
                  write(11,'(a9,i2,a)')sq//'setclef{',iinow,
     *                 '}'//hdlndq(1:lclf)//'%'
                end if
              end if
60          continue
c
c  Loop back up, this may not be last option in M.  Note flow out if durq=' '
c
            call getchar(lineq,iccount,durq)
            go to 31
          end if
c
c  Write instrument names
c
          if (.not.rename) then
            do 62 iinst = 1 , ninow
              if (islast) 
     *           write(11,'(a8,i1,a3)')sq//'setname',iinst,'{}%'
62          continue
          else
            do 65 iinst = 1 , ninow
              if (islast)
     *            write(11,'(a8,i1,a)')sq//'setname',iinst,'{'//
     *            inameq(iiorig(iinst))(1:lnam(iiorig(iinst)))//'}%'
65          continue
            rename = .false.
          end if
        end if
      else if (charq .eq.'|' ) then
c
c  End of bar symbol.  Check about end of bar hardspace.
c
        if (btest(iornq(ivx,nnl(ivx)+1),26)) then
c
c  There was a hardspace followed by a bar line.  Remove it from the hardspace
c  list, store with shifts instead, set special bit.  Need to repeat this code
c  at '/'.
c
          irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18)
          nudoff(ivx) = nudoff(ivx)+1
          udoff(ivx,nudoff(ivx)) = udsp(nudsp)
          nudsp = nudsp-1
          iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26)
        end if
      else if (index('wS',charq) .gt. 0) then
c
c  Width symbol or new nsyst.  Read past (until blank)
c
4       call getchar(lineq,iccount,durq)
        if (durq .ne. ' ') go to 4
      else if (charq .eq. 'l') then
c
c  Lower string.  Only OK if at start of block
c  Check whether at beginning of a block
c
        if (iv.ne.1 .or. nnl(1).ne.0) then
          print*,'You entered "l" not at beginning of block'
          stop
        end if
c
c  Set flag for lower string & read it in
c
        lower = .true.
        call getbuf(lowerq)
        iccount = 128
      else if (charq .eq. 'm') then
c
c  Meter change.  Only allow at beginning of block.
c    mtrnuml, mtrdenl (logical) and p (printable) will be input.
c    mtrnuml=0 initially. (In common)
c
c  Check whether at beginning of a block
c
        if (iv.ne.1 .or. nnl(1).ne.0) then
          print*,'You entered "m" not at beginning of block'
          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
        if (ismidi) call midievent('m',mtrnuml,mtrdenl)
      else if (charq .eq. 'C') then
c
c  Clef change on next note.  Set bits 11-15.  Won't allow in 2nd line of music.
c
        if (nnl(iv) .gt. 0) ncc(iv) = ncc(iv)+1
        tcc(iv,ncc(iv)) = itsofar(iv)
        isl = ibset(islur(iv,nnl(iv)+1),11)
        call getchar(lineq,iccount,durq)
c
c  Store clef number, or 7 if clef number = 9 (French violin clef)
c
        isl = ior(isl,ishft(min(numclef(durq),7),12))
cc        if (durq .ne. 'f') then
c        if (index('f7',durq) .eq. 0) then
c          ncmidcc(iv,ncc(iv)) = 35-2*iand(7,ishft(isl,-12))
c        else
cc
cc  French violin clef
cc
c          ncmidcc(iv,ncc(iv)) = 37
c        end if  
          ncmidcc(iv,ncc(iv)) = ncmidf(durq)
c
c  Set marker on note with lowest voice # starting at same time.
c
        if (iv .eq. 1) then
          isl = ibset(isl,15)
        else
          do 13 iiv = 1 , iv
            nnliiv = nnl(iiv)
            if (iiv .eq. iv) nnliiv = nnliiv+1
            itother = 0
            do 14 iip = 1 , nnliiv
              if (itother .lt. itsofar(iv)) then
                itother = itother+nodur(iiv,iip)
                go to 14
              else if (itother .eq. itsofar(iv)) then
                islur(iiv,iip) = ibset(islur(iiv,iip),15)
                go to 15
              end if
14          continue
13        continue
15        continue
        end if
c       islur(iv,nnl(iv)+1) = isl
c
c  Need 'or' since may have set bit 15 in the above loop
c
        islur(iv,nnl(iv)+1) = ior(isl,islur(iv,nnl(iv)+1))
      else if (charq .eq. 'R') then
c
c  Repeats.  set bits 5, 6, and/or 8 of islur(1,ip+1)
c
10      call getchar(lineq,iccount,durq)
c
c  Save designator in case it's a terminal Rr or Rd
c
        if (durq .eq. 'l') then
          islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),5)
          go to 10
        else if (index('rdDb',durq) .gt. 0) then
          if (durq .eq. 'r') then
            islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),6)
          else if (durq .eq. 'd') then
            islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),8)
          else if (durq .eq. 'D') then
            islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),26)
          else if (durq .eq. 'b') then
            islur(1,nnl(1)+1) = ibset(islur(1,nnl(1)+1),25)
          end if
          rptprev = .true.
          rptfq1 = durq
          go to 10
        end if
      else if (charq .eq. 'V') then
c
c  Ending
c
        nnnl = nnl(1)+1
        lvoltxt = 0
11      call getchar(lineq,iccount,durq)
        if (durq.eq.'b' .or. durq .eq.'x') then
c
c  End Volta, set bit9, and bit10 on if 'b' (end w/ box)
c
          islur(1,nnnl) = ibset(islur(1,nnnl),9)
          if (durq .eq. 'b') islur(1,nnnl) = ibset(islur(1,nnnl),10)
          go to 11
        else if (durq .ne. ' ') then
c
c  Start volta; Get text
c
          if (lvoltxt .eq. 0) then
c
c  First character for text
c
            lvoltxt = 1
            islur(1,nnnl) = ibset(islur(1,nnnl),7)
            nvolt = nvolt+1
            voltxtq(nvolt) = durq
          else
            voltxtq(nvolt) = voltxtq(nvolt)(1:lvoltxt)//durq
            lvoltxt = lvoltxt+1
          end if
          go to 11
        end if
      else if (charq .eq. 'B') then
        bcspec = .not.bcspec
      else if (charq .eq. 'P') then
c
c  Page numbers.  Print stuff right now.
c
        npg1 = 0
c
c  Will use ltopnam to signal whether there's a centered heading
c
        ltopnam = 0
        ipg1r = 0
16      call getchar(lineq,iccount,durq)
        if (ichar(durq).ge.48 .and. ichar(durq).le.57) then
          npg1 = npg1*10+ichar(durq)-48
          go to 16
        else if (durq .eq. 'l') then
          if (npg1.eq.0 .or. mod(npg1,2).eq.1) ipg1r = 1
          go to 16
        else if (durq .eq. 'r') then
          if (npg1.gt.0 .and. mod(npg1,2).eq.0) ipg1r = 1
          go to 16
        else if (durq .eq. 'c') then
c
c  Top-centered name.  Assume this is last option.  Read the name.
c  May surround name in double quotes (to allow blanks).
c
          call getchar(lineq,iccount,durq)
          if (durq .eq. ' ') then
            ltopnam = lenstr(cheadq,60)
          else
            namstrt = iccount
            if (durq .eq. '"') then
c
c  Using quote delimiters.
c
              quoted = .true.
              namstrt = namstrt+1
            else
              quoted = .false.
            end if
            do 35 iccount = namstrt+1, 128
              if ((quoted .and. lineq(iccount:iccount) .eq. '"') .or.
     *           (.not.quoted .and. lineq(iccount:iccount) .eq. ' '))
     *            go to 36
c
c  On exit, iccount is OK, and name is in (namstrt:iccount-1)
c
35          continue
            print*,'Awww, cmon, should not be here.'
            stop
36          continue
            ltopnam = iccount-namstrt
            cheadq = lineq(namstrt:iccount-1)
          end if
        end if
c
c  Done getting data, now assemble the command
c
        if (npg1.eq.0) npg1=1
        hdlndq = sq//'def'//sq//'atnextline{'//sq//'toppageno{'
        if (npg1 .lt. 10) then
c
c  Note we are overwriting the last "{"
c
          write(hdlndq(27:27),'(i1)')npg1
          lhead = 27
c        else 
        else if (npg1 .lt. 100) then
          write(hdlndq(28:30),'(i2,a1)')npg1,'}'
          lhead = 30
        else 
          write(hdlndq(28:31),'(i3,a1)')npg1,'}'
          lhead = 31
        end if
        hdlndq = hdlndq(1:lhead)//chax(ipg1r+48)//'{'
        lhead = lhead+2
        if (ltopnam .eq. 0) then
          if (islast) write(11,'(a)')hdlndq(1:lhead)//'}}%'
        else
          if (islast)
     *        write(11,'(a)')hdlndq(1:lhead)//cheadq(1:ltopnam)//'}}%'
        end if
      else if (charq .eq. 'W') then
c
c  Just get two more characters (.n), they were used in pmxa
c
        call getchar(lineq,iccount,durq)
        call getchar(lineq,iccount,durq)
      else if (charq .eq. 'T') then
        headlog = .true.
        inhead = 0
        call getchar(lineq,iccount,durq)
        if (durq .eq. 'i') then
          call getbuf(instrq)
c
c  A kluge for parts from separate score file for later movements.
c
          if (instrq(1:1) .eq. ' ') headlog = .false.
          cheadq = instrq
        else if (durq .eq. 't') then
          call getchar(lineq,iccount,durq)
c
c  Optionally can include extra vertical \internotes above inbothd
c
          if (index('-+0123456789',durq) .gt. 0) then
            ipm = 1
            if (index('+-',durq) .gt. 0) then
c
c  Don't trust readnum to round this negative integer properly
c
              iccount = iccount+1
              if (durq .eq. '-') ipm = -1
            end if
            call readnum(lineq,iccount,durq,fnum)
            inhead = ipm*nint(fnum)
          end if
          call getbuf(titleq)
        else
          call getbuf(compoq)
        end if
        inhead = inhead+inbothd
        iccount = 128
      else if (charq .eq. 'A') then
c
c  Accidental handling etc.
c
27      call getchar(lineq,iccount,durq)
        if (durq .eq. 'r') then
          if (islast) then
            relacc = .true.
            write(11,'(a)')sq//'relativeaccid%'
          end if
          go to 27
        else if (durq .eq. 's') then
          bacfac = 1.e6
          go to 27
        else if (durq .eq. 'b') then
          if (islast) write(11,'(a)')sq//'bigaccid%'
          accfac = bacfac
          go to 27
        else if (durq .eq. 'a') then
          call getchar(lineq,iccount,durq)
          call readnum(lineq,iccount,durq,fnum)
          iccount = iccount-1
          go to 27
        else if (durq .eq. 'i') then
          call getchar(lineq,iccount,durq)
          call readnum(lineq,iccount,durq,tintstf)
          if (.not.firstgulp) fintstf = tintstf
c
c  Local corrections for first page were handled by pmxa
c
          iccount = iccount-1
          go to 27
        else if (durq .eq. 'I') then
          call getchar(lineq,iccount,durq)
          call readnum(lineq,iccount,durq,gintstf)
          iccount = iccount-1
          go to 27
        else if (durq .eq. 'd') then
          lowdot = .true.
          go to 27
        else if (durq .eq. 'o') then
          go to 27
        end if
      else if (charq .eq. 'K') then
        call getchar(lineq,iccount,durq)
        num1 = 44-ichar(durq)
        iccount = iccount+1
        call readnum(lineq,iccount,durq,fnum)
        num1 = num1*nint(fnum)
c
c  On exit, durq='+','-'.  But only need isig if after start, else done in pmxa
c
        iccount = iccount+1
        call readnum(lineq,iccount,charq,fnum)
        if (num1 .eq. 0) then
c
c  Key change, not transposition.
c
          ipl(ivx,nnl(ivx)+1) = ibset(ipl(ivx,nnl(ivx)+1),28)
          lastisig = isig
          isig = nint(fnum)
          if (durq .eq. '-') isig = -isig
          isig = isig+idsig
          if (ismidi) call midievent('k',isig,0)
        else
c
c  num1 .ne. 0, so transposition, so must be at beginning.  isig came with K...
c  but was passed to pmxb through pmxtex.dat.  isig0 comes from setup data
c  (signature before transposition).  idsig must be added to future key changes.
c
          ntrans = num1
          idsig = isig-isig0
        end if
      else if (charq .eq. '/') then
        if (btest(iornq(ivx,nnl(ivx)+1),26)) then
c
c  There was a hardspace followed by end of block.  Remove it from the hardspace
c  list, store with shifts instead, set special bit.  This code also at '|'
c
          irest(ivx,nnl(ivx)) = ibset(irest(ivx,nnl(ivx)),18)
          nudoff(ivx) = nudoff(ivx)+1
          udoff(ivx,nudoff(ivx)) = udsp(nudsp)
          nudsp = nudsp-1
          iornq(ivx,nnl(ivx)+1) = ibclr(iornq(ivx,nnl(ivx)+1),26)
        end if
        call getchar(lineq,iccount,durq)
c
c  Save ending note level:
c
        if (ivx .le. nv) then
c
c  This is the first line of music on this staff.  If previous block had only 1
c  voice, save last pitch from line 1 of prev. block to line 2, in case a
c  2nd line is started just below
c
          if (.not.was2(iv)) ndlev(iv,2) = ndlev(iv,1)
          was2(iv) = .false.
          ndlev(iv,1) = lastlev
        else
c
c  This is the 2nd line of music on this staff.
c
          was2(iv) = .true.
          ndlev(iv,2) = lastlev
        end if
        if (durq .eq. ' ' .and. iv.eq.nv) then
c
c  End of input block
c
          loop = .false.
        else
c
c  Start a new line of music
c
          if (lenb0.ne.0 .and. firstgulp) lenbar = lenb0
          nbars = 0
          if (durq .eq. ' ') then
c
c  New line of music is on next staff
c
            iv = iv+1
            ivx = iv
          else
c
c  durq must be 2nd '/'.  New line of music is on same staff.  Set up for it
c
            ivx = nv+1
            do 23 iiv = 1 , nv
              if (nvmx(iiv) .eq. 2) ivx = ivx+1
23          continue
            nvmx(iv) = 2
            ivmx(iv,2) = ivx
            itsofar(ivx) = 0
            nnl(ivx) = 0
            nfb(ivx) = 0
            nudoff(ivx) = 0
            ndotmv(ivx) = 0
            do 24 j = 1 , 200
              irest(ivx,j) = 0
              islur(ivx,j) = 0
              nacc(ivx,j) = 0
              iornq(ivx,j) = 0
              ipl(ivx,j) = 0
24          continue
c
c  Go back and lower the rests in voice "a" that don't have over-ridden heights
c
            do 26 j = 1 , nnl(iv)
              if (btest(irest(iv,j),0) .and. nolev(iv,j).eq.0)
     *            nolev(iv,j) = -4
26          continue
          end if
        end if
        iccount = 128
      else if (charq .eq. 'X') then
c
c  3rd arg is only for termination of group shifts.  Use "max" to avoid zero index, 
c    which only happens for normal X at block start, and we took special measures to
c    keep group shifts for crossing block boundaries.  
c
        call getx(lineq,iccount,irest(ivx,max(1,nnl(ivx))),
     *            shifton,wheadpt,iornq(ivx,nnl(ivx)+1),ivx,
     *            irest(ivx,nnl(ivx)+1),itsofar(ivx),0,0,0,' ')
      else if (charq .eq. 'I') then
c
c  Midi controls.  
c
        call getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar,
     *               mtrdenl,.false.)
      else if (charq .eq. 'M') then
c
c  Macro action
c
        call getchar(lineq,iccount,charq)
        if (index('RS',charq) .gt. 0) then
c
c  Record or save a macro.  Get the number of the macro.
c
          call getchar(lineq,iccount,durq)
          call readnum(lineq,iccount,durq,fnum)
          macnum = nint(fnum)
          macuse = ibset(macuse,macnum)
          if (charq .eq. 'R') then
            call mrec1(lineq,iccount,ndxm)
          else
c
c  Save (Record but don't activate)
c
5           call mrec1(lineq,iccount,ndxm)
            if (mrecord) then
              call getbuf(lineq)
              iccount = 0
              go to 5
            end if
            iccount = iccount+ndxm+1
          end if
        else if (charq .eq. 'P') then
c
c  Playback the macro
c
          call getchar(lineq,iccount,charq)
          call readnum(lineq,iccount,durq,fnum)
          macnum = nint(fnum)
          icchold = iccount
          lnholdq = lineq
          iccount = 128
          ilmac = il1mac(macnum)
          mplay = .true.
        end if
      end if
      return
      end
      subroutine getchar(lineq,iccount,charq)
      parameter (nm=12)
c
c  Gets the next character out of lineq*128.  If pointer iccount=128 on entry,
c  then reads in a new line.  Resets iccount.  Ends program if no more input.
c
      common /comget/ lastchar,rptnd1,sluron(nm,2),fbon,ornrpt,
     *       movbrk,movnmp,movdnp,movgap,parmov,fintstf,gintstf,
     *       rptprev,rptfq1,rptfq2
      logical lastchar,rptnd1,sluron,fbon,rptprev,ornrpt
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      logical mrecord,mplay,endmac
      character*1 charq,rptfq1,rptfq2
      character*128 lineq,lnholdq
      if (iccount .eq. 128) then
        call read10(lineq,lastchar)
        if (lastchar) return
        if (.not. endmac) then
          iccount = 0
        else
          endmac = .false.
          iccount = icchold
          lineq = lnholdq
        end if
        if (mrecord) then
          call mrec1(lineq,iccount,ndxm)
        end if
      end if
      iccount = iccount+1
      charq = lineq(iccount:iccount)
      return
999   continue
      lastchar = .true.
      return
      end
      function log2(n)
        log2 = alog(1.*n)/0.6931472+.0001
      return
      end
      function ifnolev(noq,oct)
      common /comtrans/ ntrans,cheadq
        character*1 noq
        character*60 cheadq
        integer oct
        ifnolev = 7*oct+mod(ichar(noq)-92,7)+1+ntrans
      return
      end
      function ifnodur(idur,dotq)
        character*1 dotq
        if (idur .eq. 6) then
          ifnodur=1
        else if (idur .eq. 3)then
          ifnodur=2
        else if(idur .eq. 1) then
          ifnodur=4
        else if(idur .eq. 8) then
          ifnodur=8
        else if(idur .eq. 4) then
          ifnodur=16
        else if(idur .eq. 2) then
          ifnodur=32
        else if(idur .eq. 0) then
          ifnodur=64
        else if(idur .eq. 9) then
          ifnodur=128
        else if (idur .eq. 16) then
c
c  Only used for denominator of time signatures, not for notes
c
          ifnodur=4
        else
          print*,'You entered an invalid note value'
          stop
        end if
        if (dotq .eq. 'd') ifnodur = ifnodur*3/2
      return
      end
      function ncmidf(clefq)
c
c  Return middle line of a clef
c
      character*1 clefq
c      if (clefq.eq.'t' .or. clefq.eq.'0') then
c        ncmidf = 35
c      else if (clefq.eq.'s' .or. clefq.eq.'1') then
c        ncmidf = 33
c      else if (clefq.eq.'m' .or. clefq.eq.'2') then
c        ncmidf = 31
c      else if (clefq.eq.'a' .or. clefq.eq.'3') then
c        ncmidf = 29
c      else if (clefq.eq.'n' .or. clefq.eq.'4') then
c        ncmidf = 27
c      else if (clefq.eq.'r' .or. clefq.eq.'5') then
c        ncmidf = 25
c      else if (clefq.eq.'f' .or. clefq.eq.'7') then
c        ncmidf = 37
c      else
c        ncmidf = 23
c      end if
      ncmidf = 21+index(' b6r5n4a3m2s1t0f7',clefq)/2*2
      return
      end
      subroutine beamstrt(notexq,lnote,nornb,ihornb,space,squez,ib)
      parameter (nm=12)
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      character*1 ulq,sepsymq,sq
      character*79 inameq
      logical beamon,firstgulp,figbass,figcheck,btest,
     *        isfig,vxtup,bar1syst,addbrack,flipend,xto
      common /comoct/ noctup
      common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
      common /comxtup/ ixtup,vxtup(nm),ntupv(nm),nolev1(nm),
     *                 islope(nm),xelsk(24),eloff(nm)
      common /comas1/ naskb,task(20),wask(20),elask(20)
      common /comask/ bar1syst,fixednew,scaldold,
     *                wheadpt,fbar,poenom
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,idsig,
     *   lnam(nm),inameq(nm)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      character*8 noteq
      character*79 notexq,tempq
      integer ipb(24),nornb(nm),ihornb(nm,24)
      real*4 space(80),squez(80)
      ibc = ibmcnt(ivx)
      ipb1 = ibm1(ivx,ibc)
      multb = mult(ivx,ipb1)
c
c  Move the following into SetupB, since xtup may be embedded and not start
c  on same note as beam.  
c      if (btest(irest(ivx,ipb1),28)) then
c
c  Compute slopes and note offsets from start of beam.  Inside SetupB, set
c  eloff = distance from start of xtup to number.
c
      if (ixrest(ivx).eq.0) call SetupB(xelsk,nnb,sumx,sumy,ipb,
     *     smed,ixrest(ivx))
      lnote = 0
      if (btest(irest(ivx,ipb1),28) .and. ixrest(ivx).ne.2) then
        vxtup(ivx) = .true.
c
c  irest(28)=>Xtup starts on this note.  Set up for xtuplet.
c  Number goes on notehead side at middle note (or gap) of xtup, unless that
c  puts it in staff, then it flops to stem (or beam) side.
c               __          __
c         |    |  |   O    |  |
c         O      |    |      O
c       |___|    O  |__|     |
c
c  iud   -1     -1    1      1    ...stem direction
c iflop   0      1   -1      0    ...direction of flop
c  iup   -1      1   -1      1    ...direction of number and bracket
c
        iud = 1
        if (ulq(ivx,ibc) .eq. 'u') iud = -1
c
c  Get ip#, note level of middle note (or gap) in xtup
c
        ipmid = ipb1+ntupv(ivx)/2
        xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud,
     *                 ncmid(iv,ipmid),mult(ivx,ipmid))
        if (mod(ntupv(ivx),2) .eq. 0) then
          if (mod(ntupv(ivx),2) .eq. 0) xnlmid = (xnlmid+
     *            levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud,
     *            ncmid(iv,ipmid-1),mult(ivx,ipmid-1)))/2
        end if
        iflop = 0
        if (abs(xnlmid-ncmid(iv,ipb1)).lt.3.) iflop = -iud
        iup = iud+2*iflop
        if (btest(irest(ivx,ipb1),14)) then
c
c  Alter iud, iflop, iup to flip number/bracket. (Stare at above pic)
c
          iup = -iup
          iflop = 0
          if (iud*iup .lt. 0) iflop = iup
        end if
c
c  Place xtup number if needed
c
        if (.not.btest(islur(ivx,ipb1),31) .or. multb.le.0)
     *      call putxtn(ntupv(ivx),iflop,multb,iud,wheadpt,poenom,
     *      nolev1(ivx),islope(ivx),slfac,xnlmid,islur(ivx,ipb1),
     *      lnote,notexq,
     *      ncmid(iv,ipb1),nlnum,eloff(ivx),iup,irest(ivx,ipb1))
c
c  Why was this here ????????
c
        if (multb .le. 0) then
c
c  Put in the bracket. scale = stretch factor for bracket if there are asx's
c  xnsk = length of the bracket in \noteskips = (\elemskips)/(eon)
c
          xnsk = (eskz(ivx,ipb1+ntupv(ivx)-1)-eskz(ivx,ipb1))
     *           /squez(ib)/feon(space(ib)/squez(ib))
          if (iup .eq. 1) then
            if (lnote .gt. 0) then
              notexq = notexq(1:lnote)//sq//'ovbkt'
            else
              notexq = sq//'ovbkt'
            end if
          else
            if (lnote .gt. 0) then
              notexq = notexq(1:lnote)//sq//'unbkt'
            else
c
c  Introduced 12/5/98, req'd due to possible presence of in-line TeX
c
              notexq = sq//'unbkt'
            end if
          end if
          lnote = lnote+6
          if (iline.eq.1) then
            smed = smed/(1.-fracindent)
          end if
          xslope = 1.8*smed*slfac
          islope(ivx) = nint(xslope)
          nolev1(ivx) = nlnum - nint(smed*eloff(ivx))
          if (islope(ivx) .eq. 0) nolev1(ivx) = nolev1(ivx)-1
          if (iup .eq. 1) nolev1(ivx) = nolev1(ivx)+4
          call notefq(noteq,lnoten,nolev1(ivx),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(ivx).lt.0 .or. islope(ivx).ge.10) then
            notexq = notexq(1:lnote)//'{'
            lnote = lnote+1
            if (islope(ivx) .lt. -9) then
              write(notexq(lnote+1:lnote+3),'(i3)')islope(ivx)
              lnote = lnote+3
            else
              write(notexq(lnote+1:lnote+2),'(i2)')islope(ivx)
              lnote = lnote+2
            end if
            notexq = notexq(1:lnote)//'}'
            lnote = lnote+1
          else
            write(notexq(lnote+1:lnote+1),'(i1)')islope(ivx)
            lnote = lnote+1
          end if
          if (ixrest(ivx) .eq. 1) then
c
c  Put in the rest.  Possible problem: Rest is a spacing char, but between
c  beamstrt and beamn1 some non-spacing chars. are inserted.
c
            if (multb .eq. 0) then
              notexq = notexq(1:lnote)//sq//'qp'
              lnote = lnote+3
            else
              notexq = notexq(1:lnote)//sq//'hpause'
              lnote = lnote+7
            end if
c
c  No need to come back through this subroutine (as would if rest starts bar
c  & multb>0), so do not advance ibm1. But must check in beamn1 and do nothing.
c
            ixrest(ivx) = 0
          end if
          return
        end if
c
c  End if block for non-beamed xtup start...note we returned
c
        if (ixrest(ivx) .eq. 1) then
c
c  Insert rest at start of beamed xtup.  See above note for possible problem.
c
          nodur(ivx,ipb1) = 2**(4-multb)
          call notex(tempq,ltemp)
          if (lnote .gt. 0) then
            notexq = notexq(1:lnote)//tempq(1:ltemp)
          else
            notexq = tempq(1:ltemp)
          end if
          lnote = lnote+ltemp
c
c  Re-zero just in case!
c
          nodur(ivx,ipb1) = 0
          ibm1(ivx,ibc) = ibm1(ivx,ibc)+1
c
c  See if next note is a non-rest
c
          if (.not.btest(irest(ivx,ipb1+1),0)) then
            ixrest(ivx) = 2
          else
c
c  Suppress reprinting xtup number next time through beamstrt
c
            islur(ivx,ipb1+1) = ibset(islur(ivx,ipb1+1),31)
c
c  Set new xtup start flag
c
            irest(ivx,ipb1+1) = ibset(irest(ivx,ipb1+1),28)
          end if
          return
        end if
      end if
      if (vxtup(ivx) .and. ipb1.eq.ibm2(ivx,ibc)) then
c
c  Move actual note writing to beamend
c
        ixrest(ivx) = 4
        return
      end if
c
c  Adjust start level and slope if needed
c
      iadj = iand(63,ishft(ipl(ivx,ipb1),-11))-30
      if (iadj .ne. -30) nolev1(ivx) = nolev1(ivx)+iadj
      iadj = iand(63,ishft(ipl(ivx,ipb1),-17))-30
      if (iadj .ne. -30) islope(ivx) = islope(ivx)+iadj
      iadj = iand(3,ishft(islur(ivx,ipb1),-27))
      addbrack = .false.
      if (btest(ipl(ivx,ipb1),30)) then
c
c  Check for altered starting polarity.  Only in forced beams. Nominal start
c  level is nolev1. So beam level is nolev1 +/- 6, to be compared w/ nolev(.,.).
c
        if (ulq(ivx,ibc).eq.'u' .and.
     *                  nolev1(ivx)+6.lt.nolev(ivx,ipb1)) then
          if (lnote .eq. 0) then
            notexq = sq//'loff{'
          else
            notexq = notexq(1:lnote)//sq//'loff{'
          end if
          lnote = lnote+6
          addbrack = .true.
        else if (ulq(ivx,ibc).eq.'l' .and.
     *                  nolev1(ivx)-6.gt.nolev(ivx,ipb1)) then
          if (lnote .eq. 0) then
            notexq = sq//'roff{'
          else
            notexq = notexq(1:lnote)//sq//'roff{'
          end if
          lnote = lnote+6
          addbrack = .true.
        end if
c
c  Check for end level in forced beam.  Have to do it here since with multiple
c  voices, xelsk will not be preserved.
c
        if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') then
          bmlev = nolev1(ivx)+6+islope(ivx)*xelsk(nnb)/slfac
          flipend(ivx) = bmlev.lt.nolev(ivx,ibm2(ivx,ibc))
        else if (ulq(ivx,ibmcnt(ivx)) .eq. 'l') then
          bmlev = nolev1(ivx)-6+islope(ivx)*xelsk(nnb)/slfac
          flipend(ivx) = bmlev.gt.nolev(ivx,ibm2(ivx,ibc))
        end if
      end if
      call ntrbbb(multb+iadj,'i',ulq(ivx,ibc),ivx,notexq,lnote)
c
c   Put in name of start level and slope, after correcting nolev1 if xtup
c   started with a rest.
c
      if (ixrest(ivx).eq.2) nolev1(ivx) = 
     *          nint(nolev1(ivx)+xelsk(1)*islope(ivx)/slfac)
      call notefq(noteq,lnoten,nolev1(ivx),ncmid(iv,ipb1))
      iasl = min(abs(islope(ivx)),9)
      if (islope(ivx) .lt. 0) then
        notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
        lnote = lnote+4+lnoten
        write(notexq(lnote-2:lnote),'(i2,a1)')-iasl,'}'
      else
        notexq = notexq(1:lnote)//noteq(1:lnoten)
        lnote = lnote+1+lnoten
        write(notexq(lnote:lnote),'(i1)')iasl
      end if
c
c  Check for beam-thk fine-tuning
c
      if (iadj .gt. 0) then
        do 1 imp = multb+iadj , multb+1 , -1
          call ntrbbb(imp,'t',ulq(ivx,ibc),ivx,notexq,lnote)
1       continue
      end if
c
c  If we shifted, must close with right bracket
c
      if (addbrack) then
        notexq = notexq(1:lnote)//'}'
        lnote = lnote+1
      end if
c
c  Get 'floor' zmin for figures
c
      if (figbass .and. iv.eq.1) then
        zmult = 1.2*(multb-1)
        ymin = 100.
        do 3 inb = 1, nnb
          if (isfig(ipb(inb))) then
            if (ulq(1,ibc) .eq. 'u') then
      	ybot = nolev(1,ipb(inb))
            else
      	ybot = islope(ivx)/slfac*xelsk(inb)+nolev1(ivx)-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
      NomOrnLev = ncmid(iv,ipb1)+5
      iorn = 0
      do 8 inb = 1 , nnb
        ip = ipb(inb)
        if (.not.btest(iornq(ivx,ip),23)) go to 8
c
c  Bits 0-13: (stmgx+Tupf._) , 14: Down fermata, was F
c  15: Trill w/o "tr", was U , 16-18 Editorial s,f,n , 19-21 TBD
c
        if (.not.btest(ipl(ivx,ip),10)) then
c
c  Non-chord.  There IS an ornament.  Need ihornb only if upbeam, and if
c  ornament is 1,2,3,5,6,7,8,9,10,15-21 (up- but not domn ferm.)
c
          if (ulq(ivx,ibc).eq.'u' .and.
     *          iand(iornq(ivx,ipb(inb)),4163566).gt.0) then
            iorn = iorn+1
            iornq(ivx,ip) = ibset(iornq(ivx,ip),22)
            ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1
     *                  +1.2*(multb-1)
            ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev)
          end if
        else
c
c In a chord.  Orn may be on main note or non-main or both.  Set ihornb if
c upbeam and highest note has orn, or down beam and lowest.  Find 1st chord note
c
          do 10 icrd1 = 1 , ncrd
            if (iand(255,icrdat(icrd1)) .eq. ip  .and.
     *           iand(15,ishft(icrdat(icrd1),-8)) .eq. ivx) go to 11
10        continue
11        continue
c
c Find outermost note, min or max depending on beam direction ulq.  xto is true
c if there's an ornament on that note.  Expand orn list to include ._, since if
c on extreme chord note in beam, will move.
c So ornaments are all except 0,4,13 (,g,)
c
          levx = nolev(ivx,ip)
          xto = iand(iornq(ivx,ipb(inb)),4186094).gt.0
          icrdx = 0
          do 12 icrd = icrd1 , ncrd
            if (iand(255,icrdat(icrd)) .ne. ip  .or.
     *               iand(15,ishft(icrdat(icrd),-8)) .ne. ivx) go to 13
            levc = iand(127,ishft(icrdat(icrd),-12))
            if ((ulq(ivx,ibc).eq.'u'.and.levc.gt.levx) .or.
     *            (ulq(ivx,ibc).eq.'l'.and.levc.lt.levx)) then
              levx = levc
              icrdx = icrd
              xto = iand(icrdorn(icrd),4186094).gt.0
            end if
12        continue
13        continue
c
c  If there's orn on extreme note, do stuff
c
          if (xto) then
            iorn = iorn+1
            if (ulq(ivx,ibc) .eq. 'u') then
              ybeam = nolev1(ivx)+stemlen+islope(ivx)*xelsk(inb)/slfac-1
     *                  +1.2*(multb-1)
              ihornb(ivx,iorn) = max(nint(ybeam+3.),NomOrnLev)
            else
              ybeam = nolev1(ivx)-stemlen+islope(ivx)*xelsk(inb)/slfac+1
     *                  -1.2*(multb-1)
              ihornb(ivx,iorn) = min(nint(ybeam-3.),NomOrnLev-10)
            end if
            if (icrdx .eq. 0) then
c
c  Affected ornament is on main note
c
              iornq(ivx,ip) = ibset(iornq(ivx,ip),22)
            else
              icrdorn(icrdx) = ibset(icrdorn(icrdx),22)
            end if
          end if
        end if
8     continue
c
c  Henceforth nornb will be a counter.
c
      if (iorn .gt. 0) nornb(ivx)=1
      if (ixrest(ivx) .eq. 2) ixrest(ivx) = 0
      return
      end
      subroutine beamn1(notexq,lnote)
      parameter (nm=12)
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      character*1 ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,btest,
     *        isfig,vxtup,isdotm,isbjmp
      common /combjmp/ ivbjmp,isbjmp
      common /comoct/ noctup
      common /comxtup/ ixtup,vxtup(nm),ntupv(nm),nolev1(nm),
     *                 islope(nm),xelsk(24),eloff(nm)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*8 noteq
      character*79 notexq
      ip1 = ibm1(ivx,ibmcnt(ivx))
      multip = mult(ivx,ip1)
      if (multip.le.0 .and. btest(irest(ivx,ip1),0)) then
        lnote = 0
c
c  The rest was already written in beamstrt, so just get out of here
c
        return
      end if
      if (vxtup(ivx) .and. multip.le.0) then
c
c  Xtuplet with no beam, just put in the right kind of note
c
        if (btest(islur(ivx,ip1),30)) then
c
c  Forced stem direction
c
          ndsav = nodur(ivx,ip1)
          nodur(ivx,ip1) = 2**(4-multip)
          call notex(notexq,lnote)
          nodur(ivx,ip1) = ndsav
        else
          call notefq(noteq,lnoten,nolev(ivx,ipo(jn)),ncmid(iv,ip1))
          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
        end if
        return
      end if
c
c  Check if mult. decreases from 1st note to 2nd
c
      if (ibm2(ivx,ibmcnt(ivx)) .gt. ip1) then
        if (.not.btest(irest(ivx,ip1+1),0)) then
          multr = mult(ivx,ip1+1)
        else
          multr = mult(ivx,ip1+2)
        end if
        lnote = 0
        if (multr .lt. multip) then
          do 1 im = multip , multr+1 , -1
            call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
1         continue
        end if
      end if
c
c  Put in the note
c
      if (lnote .gt. 0) then
        notexq = notexq(1:lnote)//sq//'qb'
      else
        notexq = sq//'qb'
      end if
      lnote = lnote+3
c
c  Check for dot
c
      isdotm = .false.
      if (.not.vxtup(ivx)) then
        nd = nodur(ivx,ipo(jn))
        if (nd.ne.0) then
          if (2**log2(nd).ne.nd) then
            if (.not.btest(iornq(ivx,ip1),13)) then
              if (.not.btest(islur(ivx,ip1),3)) then
                notexq = notexq(1:lnote)//'p'
              else
c
c  Double dot
c
                notexq = notexq(1:lnote)//'pp'
                lnote = lnote+1
              end if
            else
              notexq = notexq(1:lnote)//'m'
              isdotm = .true.
            end if
            lnote = lnote+1
          end if
        end if
      end if
c
c  Do the number; 0 if 12
c
      if (.not.btest(irest(ivx,ip1),24)) then
        call istring(mod(ivx,12),noteq,len)
      else
        call istring(mod(ivbjmp,12),noteq,len)
        isbjmp = .true.
      end if
      notexq = notexq(1:lnote)//noteq(1:len)
      lnote = lnote+len
      call notefq(noteq,lnoten,nolev(ivx,ipo(jn)),ncmid(iv,ip1))
      notexq = notexq(1:lnote)//noteq(1:lnoten)
      lnote = lnote+lnoten
      if (isdotm) then
        if (lnoten .eq. 1) then
          notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}'
          lnote = lnote+3
        else
          notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
          lnote = lnote+1
        end if
      end if
      return
      end
      subroutine beamend(notexq,lnote)
      parameter (nm=12)
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      character*1 ulq,sepsymq,sq,ulqq,chax
      logical beamon,firstgulp,figbass,figcheck,flipend,btest,
     *        isfig,vxtup,isdotm,isbjmp
      common /combjmp/ ivbjmp,isbjmp
      common /comoct/ noctup
      common /comxtup/ ixtup,vxtup(nm),ntupv(nm),nolev1(nm),
     *                 islope(nm),xelsk(24),eloff(nm)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
      character*4 tempq
      character*8 noteq
      character*79 notexq
      ip = ipo(jn)
      multip = mult(ivx,ip)
      if (ixrest(ivx) .eq. 4) then
c
c  This is the LAST note in the xtup (i.e., all rests before).  Make single.
c
        nodur(ivx,ip) = 2**(4-multip)
        call notex(notexq,lnote)
        ixrest(ivx) = 0
        return
      end if
      if (vxtup(ivx) .and. multip.le.0) then
c
c  Xtuplet with no beam, just put in the right kind of note
c
        if (btest(islur(ivx,ip),30)) then
c
c  Forced stem direction
c
          ndsav = nodur(ivx,ip)
          nodur(ivx,ip) = 2**(4-multip)
          call notex(notexq,lnote)
          nodur(ivx,ip) = ndsav
        else
          call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
          if (lnoten .eq. 1) call addblank(noteq,lnoten)
          if (multip .eq. 0) then
            notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq
          else if (multip .eq. -1) then
            notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
          end if
          lnote = lnoten+3
        end if
        return
      end if
      call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
      lnote = 0
c
c New way, with flipend, which was computed in beamstrt.
c
      if (btest(ipl(ivx,ip),30) .and. flipend(ivx))
     *  ulq(ivx,ibmcnt(ivx)) = chax(225-ichar(ulq(ivx,ibmcnt(ivx))))
      if (ip .gt. ibm1(ivx,ibmcnt(ivx))) then
c
c This is not a one-noter from beam-jump.  Check if multiplicity has increased
c
        if (btest(irest(ivx,ip-1),0)) then
c
c  Prior note is a rest, check one before that
c
          mp = mult(ivx,ip-2)
        else
          mp = mult(ivx,ip-1)
        end if
        if (multip .gt. mp) then
c
c  Assume 1-3, 2-3, or 1-2
c
          do 2 imp = multip , mp+1 , -1
            call ntrbbb(imp,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
2         continue
        end if
      end if
c
c Now the normal beam termination
c
      if (.not. btest(irest(ivx,ip),23)) then
c
c  Don't terminate if starting a beam jump
c
        ulqq = ulq(ivx,ibmcnt(ivx))
        if (.not.isbjmp) then
          ivbm = ivx
        else
          ivbm = ivbjmp
          ulqq = chax(225-ichar(ulqq))
        end if
        call ntrbbb(1,'t',ulqq,ivbm,notexq,lnote)
      else
        ivbjmp = ivx
      end if
c
c  And now the note
c
      if (lnote .gt. 0) then
        notexq = notexq(1:lnote)//sq//'qb'
      else
        notexq = sq//'qb'
      end if
      lnote = lnote+3
      isdotm = .false.
      if (.not.vxtup(ivx)) then
        if (2**log2(nodur(ivx,ip)) .ne. nodur(ivx,ip)) then
          if (.not.btest(iornq(ivx,ip),13)) then
            notexq = notexq(1:lnote)//'p'
          else
            notexq = notexq(1:lnote)//'m'
            isdotm = .true.
          end if
          lnote = lnote+1
        end if
      end if
      if (.not.isbjmp) then
        call istring(mod(ivx,12),tempq,len)
      else
        call istring(mod(ivbjmp,12),tempq,len)
        isbjmp = .false.
      end if
      notexq = notexq(1:lnote)//tempq(1:len)
      lnote = lnote+len
      notexq = notexq(1:lnote)//noteq(1:lnoten)
      lnote = lnote+lnoten
      if (isdotm) then
        if (lnoten .eq. 1) then
          notexq = notexq(1:lnote)//'{'//noteq(1:1)//'}'
          lnote = lnote+3
        else
          notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
          lnote = lnote+1
        end if
      end if
      return
      end
      subroutine beamid(notexq,lnote)
      parameter (nm=12)
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      character*1 ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,flipend,btest,
     *        isfig,vxtup,isdotm,isbjmp,bar1syst,isdotted
      character*79 notexq
      common /combjmp/ ivbjmp,isbjmp
      common /comoct/ noctup
      common /strtmid/ ihnum3,flipend(nm),ixrest(nm)
      common /comxtup/ ixtup,vxtup(nm),ntupv(nm),nolev1(nm),
     *                 islope(nm),xelsk(24),eloff(nm)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comask/ bar1syst,fixednew,scaldold,
     *                wheadpt,fbar,poenom
      character*8 noteq
      character*4 tempq
        lnote = 0
        ip = ipo(jn)
        if (.not.btest(irest(ivx,ip),0)) then
          multip = mult(ivx,ip)
c          if (btest(islur(ivx,ip-1),3)) multip = multip+1
c
c  (Above test OK since must have ip>1).  Double dotted note preceding
c
c  Move the following, because can't ask for note until after checking for
c  embedded xtup with number, due to ordering/octave feature.
c
c         call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
        end if
        if (btest(irest(ivx,ip),28)) vxtup(ivx) = .true.
        if (vxtup(ivx)) then
c
c  In an xtup
c
          if (btest(irest(ivx,ip),0)) then
c
c  Intermediate rest in xtup, put in the rest.  Reset nodur so notex works OK
c
            nodur(ivx,ip) = 2**(4-mult(ivx,ip))
            call notex(notexq,lnote)
c
c  Re-zero so next note does not get confused
c
            nodur(ivx,ip) = 0
            return
          end if
          if (multip.le.0) then
c
c  Xtuplet with no beam, just put in the right kind of note
c
            if (btest(islur(ivx,ip),30)) then
c
c  Forced stem direction
c
              ndsav = nodur(ivx,ip)
              nodur(ivx,ip) = 2**(4-multip)
              call notex(notexq,lnote)
              nodur(ivx,ip) = ndsav
            else
              call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
              if (lnoten .eq. 1) call addblank(noteq,lnoten)
              if (multip .eq. 0) then
                notexq = sq//'q'//ulq(ivx,ibmcnt(ivx))//noteq
              else if (multip .eq. -1) then
                notexq = sq//'h'//ulq(ivx,ibmcnt(ivx))//noteq
              end if
              lnote = lnoten+3
            end if
            return
          else if (nodur(ivx,ip).eq.0) then
c
c  In the beamed xtup but not the last note
c
            if (nodur(ivx,ip-1).gt.0) then
c
c  Embedded Xtup, mult>0, starts here.  Put in number if needed
c
              iud = 1
              if (ulq(ivx,ibmcnt(ivx)) .eq. 'u') iud = -1
c
c  Get ip#, notelevel of middle note (or gap) in xtup
c
              ipmid = ip+ntupv(ivx)/2
              xnlmid = levrn(nolev(ivx,ipmid),irest(ivx,ipmid),iud,
     *                       ncmid(iv,ipmid),mult(ivx,ipmid))
              if (mod(ntupv(ivx),2) .eq. 0) xnlmid = (xnlmid+
     *            levrn(nolev(ivx,ipmid-1),irest(ivx,ipmid-1),iud,
     *            ncmid(iv,ipmid-1),mult(ivx,ipmid-1)))/2
              iflop = 0
              if (abs(xnlmid-ncmid(iv,ip)).lt.3.) iflop = -iud
              iup = iud+2*iflop
              if (btest(irest(ivx,ip),14)) then
                iup = -iup
                iflop = 0
                if (iud*iup .lt. 0) iflop = iup
              end if
c
c  Place number if needed
c
              if (.not.btest(islur(ivx,ip),31)) call putxtn(ntupv(ivx),
     *            iflop,multip,iud,wheadpt,poenom,
     *            nolev1(ivx),islope(ivx),slfac,
     *            xnlmid,islur(ivx,ip),lnote,notexq,ncmid(iv,ip),nlnum,
     *            eloff(ivx),iup,irest(ivx,ip))
              call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
            else
c
c  Intermediate note of xtup
c
              call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
            end if
          else
c
c  Last note of xtup (but not last note of beam!)
c
            call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
          end if
        else if (btest(irest(ivx,ip),0)) then
          call notex(notexq,lnote)
          return
        else
          call notefq(noteq,lnoten,nolev(ivx,ip),ncmid(iv,ip))
        end if
c
c Check if multiplicity changes in a way requiring action
c
        ipleft = ip-1
        if (btest(irest(ivx,ipleft),0)) ipleft = ipleft-1
        if (.not.btest(islur(ivx,ipleft),20)) then
          multl = mult(ivx,ipleft)
        else
          multl = 1
        end if
        mub = multip - multl
        ipright = ip+1
        if (btest(irest(ivx,ipright),0)) ipright = ipright-1
        if (.not.btest(islur(ivx,ip),20)) then
          multr = mult(ivx,ipright)
        else
          multr = 1
        end if
        mua = multr-multip
        if (mub.gt.0 .or. mua .lt. 0) then
c
c  Multiplicity has increased from left or will decrease to right. Need action.
c
          if (mua .ge. 0) then
            call ntrbbb(multip,'n',ulq(ivx,ibmcnt(ivx)),
     *                  ivx,notexq,lnote)
          else if (multl .ge. multr) then
            do 1 im = multip , 1+multr, -1
              call ntrbbb(im,'t',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
1           continue
          else
            do 2 im = 1+multr, multip
              call ntrbbb(im,'r',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
2           continue
            call ntrbbb(multr,'n',ulq(ivx,ibmcnt(ivx)),ivx,notexq,lnote)
          end if
        end if
c
c Now put in the note
c
        if (lnote .gt. 0) then
          notexq = notexq(1:lnote)//sq//'qb'
        else
          notexq = sq//'qb'
        end if
        lnote = lnote+3
        isdotm = .false.
        if (isdotted(nodur,ivx,ip)) then
c
c rule out ')'
c
          if (.not.btest(iornq(ivx,ip),13)) then
            if (.not.btest(islur(ivx,ip),3)) then
              notexq = notexq(1:lnote)//'p'
            else
c
c  Double dot
c
              notexq = notexq(1:lnote)//'pp'
              lnote = lnote+1
            end if
          else
            notexq = notexq(1:lnote)//'m'
            isdotm = .true.
          end if
          lnote = lnote+1
        end if
        if (.not.isbjmp) then
          call istring(mod(ivx,12),tempq,len)
        else
          call istring(mod(ivbjmp,12),tempq,len)
        end if
        notexq = notexq(1:lnote)//tempq(1:len)
        lnote = lnote+len
        notexq = notexq(1:lnote)//noteq(1:lnoten)
        lnote = lnote+lnoten
        if (isdotm) then
          if (lnoten .eq. 2) then
            notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}'
            lnote = lnote+3
          else
            notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
            lnote = lnote+1
          end if
        end if
      return
      end
      subroutine ntrbbb(n,char1q,ulqq,iv,notexq,lnote)
c
c  This appends to notexq e.g. '\ibbbu1'
c
      character*79 notexq
      character*1 char1q,ulqq,chax
      character*4 tempq
      if (lnote .gt. 0) then
        notexq = notexq(1:lnote)//chax(92)//char1q
      else
        notexq = chax(92)//char1q
      end if
      lnote = lnote+2
      do 3 im = 1 , n
        notexq = notexq(1:lnote)//'b'
        lnote = lnote+1
3     continue
c
c  add the number, 0 if 12
c
      call istring(mod(iv,12),tempq,len)
      notexq = notexq(1:lnote)//ulqq//tempq(1:len)
      lnote = lnote+1+len
      return
      end
      subroutine addstr(notexq,lnote,soutq,lsout)
      common /comlast/ islast
      logical islast
        character*(*) notexq
        character*80 soutq
        if (lsout+lnote .gt. 72) then
          if (islast) write(11,'(a)')soutq(1:lsout)//'%'
          lsout = 0
        end if
        if (lsout .gt. 0) then
          soutq = soutq(1:lsout)//notexq(1:lnote)
        else
          soutq = notexq(1:lnote)
        end if
        lsout = lsout+lnote
      return
      end
      subroutine notefq(noteq,lnote,nolev,ncmid)
c
c  Returns name of note level with octave transpositions, updates noctup.
c
      common /comoct/ noctup
      character*8 noteq
      character*1 upcaseq,noteqt,chax
      nupfroma = mod(nolev+1,7)
      iname = 97+nupfroma
      ioctup = (nolev+1)/7-4
      noteqt = chax(iname)
      if (ncmid .eq. 23) noteqt = upcaseq(noteqt)
      if (ioctup .eq. noctup) then
        noteq = noteqt
        lnote = 1
c
c  Must ALWAYS check if lnote=1 for use with functions requiring a blank
c
      else if (ioctup .gt. noctup) then
c
c  Raise octave.  Encase in {}
c
        write(noteq,'(8a1)')'{',(chax(39),i=noctup,ioctup-1),
     *                        noteqt,'}'
        lnote = 3+ioctup-noctup
        noctup = ioctup
      else
c
c  Lower octave
c
        write(noteq,'(8a1)')'{',(chax(96),i=ioctup,noctup-1),
     *                        noteqt,'}'
        lnote = 3+noctup-ioctup
        noctup = ioctup
      end if
      return
      end
      subroutine notex(notexq,lnote)
c
c  Returns non-beamed full note name
c
      parameter (nm=12)
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*1 ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,
     *        isfig,ispoi,btest
      character*1 udq,udqq,chax
      character*2 dotq
      character*79 notexq
      character*8 noteq,restq
      common /compoi/ ispoi
      ip = ipo(jn)
      nole = nolev(ivx,ip)
      nodu = nodur(ivx,ip)
      if (.not.btest(irest(ivx,ip),0)) then
        udq = udqq(nole,ncmid(iv,ip),
     *       islur(ivx,ip),nvmx(iv),ivx,nv)
      end if
c
c  Check figure level
c
      if (figbass .and. ivx.eq.1 .and. isfig(ip)
     *                    .and. .not.btest(irest(ivx,ip),0)) then
        if (udq .eq. 'u') then
c
c  Upper stem, fnole (in noleunits) set by notehead
c
          fnole = nole
        else
c
c  Lower stem, fnole set by bottom of stem
c
          fnole = nole-stemlen
        end if
        zmin = fnole-ncmid(1,ip)+4
        ifigdrop(iline) = max(ifigdrop(iline),nint(4-zmin))
      end if
      if (.not.btest(irest(ivx,ip),0)) then
        call notefq(noteq,lnoten,nole,ncmid(iv,ip))
        if (lnoten .eq. 1) call addblank(noteq,lnoten)
        if (nodu .eq. 1) then
          notexq =sq//'cccc'//udq//noteq(1:lnoten)
          lnote = lnoten+6
        else if (nodu .eq. 2) then
          notexq =sq//'ccc'//udq//noteq(1:lnoten)
          lnote = lnoten+5
        else if (nodu .eq. 4) then
          notexq =sq//'cc'//udq//noteq(1:lnoten)
          lnote = lnoten+4
        else if (nodu .eq. 8) then
          notexq =sq//'c'//udq//noteq(1:lnoten)
          lnote = lnoten+3
        else if (nodu .eq. 16) then
          notexq =sq//'q'//udq//noteq(1:lnoten)
          lnote = lnoten+3
        else if (nodu .eq. 32) then
          notexq =sq//'h'//udq//noteq(1:lnoten)
          lnote = lnoten+3
        else if (nodu .eq. 64) then
          notexq =sq//'wh'//noteq(1:lnoten)
          lnote = lnoten+3
        else if (nodu .eq. 128) then
c          notexq =sq//'zbreve'//noteq(1:lnoten)//sq//'sk'
c          lnote = lnoten+10
          notexq =sq//'breve'//noteq(1:lnoten)
          lnote = lnoten+6
        else
          dotq = 'p'
          ldot = 1
          if (btest(iornq(ivx,ip),13)) then
c
c  Dotted note with ')' ornament
c
            dotq='m'
          else if (btest(islur(ivx,ip),3)) then
c
c  Double dot
c
            dotq = 'pp'
            ldot = 2
          end if
          if (nodu .ge. 96) then
            notexq =sq//'wh'//dotq(1:ldot)//noteq(1:lnoten)
            lnote = lnoten+3+ldot
          else if (nodu .ge. 48) then
            notexq =sq//'h'//udq//dotq(1:ldot)//noteq(1:lnoten)
            lnote = lnoten+3+ldot
          else if (nodu .ge. 24) then
            notexq =sq//'q'//udq//dotq(1:ldot)//noteq(1:lnoten)
            lnote = lnoten+3+ldot
          else if (nodu .ge. 12) then
            notexq =sq//'c'//udq//dotq(1:ldot)//noteq(1:lnoten)
            lnote = lnoten+3+ldot
          else if (nodu .ge. 6) then
            notexq =sq//'cc'//udq//dotq(1:ldot)//noteq(1:lnoten)
            lnote = lnoten+4+ldot
            ispoi = .true.
          else
            notexq =sq//'ccc'//udq//dotq(1:ldot)//noteq(1:lnoten)
            lnote = lnoten+5+ldot
            ispoi = .true.
          end if
          if (dotq(1:1) .eq. 'm') then
c
c  Need another call to the note, in case the first one has octave shifts
c
            if (lnoten .eq. 2) then
              notexq = notexq(1:lnote)//'{'//noteq(2:2)//'}'
              lnote = lnote+3
            else
              notexq = notexq(1:lnote)//noteq(lnoten-1:lnoten-1)
              lnote = lnote+1
            end if
          end if
        end if
      else if (btest(islur(ivx,ip),29)) then
c
c  Blank rest
c
        notexq = sq//'sk'
        lnote = 3
      else
c
c  Non-blank rest
c
        lnote = 0
        nole = mod(nole+20,100)-20
c
c  Kluge to get pause symbol for rp:
c
        if (btest(islur(ivx,ip),19)) nodu = 64
        if (nodu .le. 28) then
c
c  Normal rest < or = double-dotted quarter
c
          lrest = 3
          if (nodu .gt. 14) then
            restq =sq//'qp'
          else if (nodu .gt. 7) then
            restq =sq//'ds'
          else if (nodu .gt. 3) then
            restq =sq//'qs'
          else if (nodu .gt. 1) then
            restq =sq//'hs'
          else
            restq =sq//'qqs'
            lrest = 4
          end if
          if (2**log2(nodu) .ne. nodu) then
c
c  One or two dots on rest
c
            restq = restq(1:3)//'p'
            lrest = 4
            if (2*nodu .gt. 3*2**log2(nodu)) then
c
c  Double dotted rest
c
              restq = restq(1:4)//'p'
              lrest = 5
            end if 
          end if
          notexq = restq
          lnote = lrest
c
c  At this point notexq=restq,lnote=lrest are name of rest.  Now raise if necc.
c
          if (nole .ne. 0) then
            if (abs(nole) .lt. 10) then
              noteq = chax(48+abs(nole))
              lnoten = 1
            else
              write(noteq(1:2),'(i2)')abs(nole)
              lnoten = 2
            end if
            if (nole .gt. 0) then
              notexq = sq//'raise'//noteq(1:lnoten)//sq//'internote'
            else
              notexq = sq//'lower'//noteq(1:lnoten)//sq//'internote'
            end if
            lnote = 16+lnoten
            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
c
c  Half or whole rest is not raised or lowered
c
            if (nodu .le. 56) then
              notexq =sq//'hpause'
              lnote = 7
c            else if (nodu .le. 112) then
c              notexq =sq//'pause'
c              lnote = 6
            else if (nodu .le. 112) then
c              if (.not.btest(islur(ivx,ip),19)) then
              if (.not.btest(islur(ivx,ip),19) .or. 
     *                      btest(irest(ivx,ip),25)) then
                notexq = sq//'pause'
              else
                notexq = sq//'pausc'
              end if
              lnote = 6
            else
              notexq =sq//'PAuse'
              lnote = 6
            end if
            if (2**log2(nodu) .ne. nodu) then
c
c  Dotted rest, hpause or longer
c
              notexq = notexq(1:lnote)//'p'
              lnote = lnote+1
              if (2*nodu .gt. 3*2**log2(nodu)) then
c
c  Double dotted long rest
c
                notexq = notexq(1:lnote)//'p'
                lnote = lnote+1
              end if
            end if
          else
c
c  Raised or lowered half or whole rest
c
            if (nodu .eq. 32) then
              notexq = sq//'lifthpause'
              lnote = 11
            else if (nodu .eq. 48) then
              notexq = sq//'lifthpausep'
              lnote = 12
            else if (nodu .eq. 56) then
              notexq = sq//'lifthpausepp'
              lnote = 13
            else if (nodu .eq. 64) then
              notexq = sq//'liftpause'
              lnote = 10
            else if (nodu .eq. 96) then
              notexq = sq//'liftpausep'
              lnote = 11
            else if (nodu .eq. 112) then
              notexq = sq//'liftpausepp'
              lnote = 12
            else
c
c  Assume double whole rest
c
              notexq = sq//'liftPAuse'
              lnote = 10
            end if
c
c  Set up height spec
c
            nole = sign(abs(nole)/2,nole)
            if (nole.le.9 .and. nole.ge.0) then
              noteq = chax(48+nole)
              lnoten = 1
            else
              noteq = '{'
              if (nole .ge. -9) then
                write(noteq(2:3),'(i2)')nole
                lnoten = 3
              else
                write(noteq(2:4),'(i3)')nole
                lnoten = 4
              end if
              noteq = noteq(1:lnoten)//'}'
              lnoten = lnoten+1
            end if
            notexq = notexq(1:lnote)//noteq(1:lnoten)
            lnote = lnote+lnoten
          end if
        end if
      end if
      return
      end
      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=12)
      dimension mask(49,3),nummask(3),eqonly(49,3)
      integer numbms(nm),ipr(48),nip1(0:47),nip2(0:47),mapfb(16),
     *       itr(48),nodue(48)
      logical short(48),eqonly
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      common /combeam/ ibmtyp
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtol/ tol
      character*1 ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,
     *        isfig,btest
      data nip1,nip2 /96*0/
      data nummask / 29 , 49 , 12 /
      data mask
     * /  65535,     4095,    65520,      255,    65280,       63,
     *      252,    16128,    64512,       15,      240,     3840,
     *    61440,        7,       14,      112,      224,     1792,
     *     3584,    28672,    57344,        3,       12,       48,
     *      192,      768,     3072,    12288,    49152, 20*0 ,
     * 16777215,    65535, 16776960,     4095,    65520,  1048320,
     * 16773120,      255,    65280, 16711680,       63,      252,
     *    16128,    64512,  4128768, 16515072,       15,       60,
     *      240,     3840,    15360,    61440,   983040,  3932160,
     * 15728640,        7,       14,      112,      224,     1792,
     *     3584,    28672,    57344,   458752,   917504,  7340032,
     * 14680064,        3,       12,       48,      192,      768,
     *     3072,    12288,    49152,   196608,   786432,  3145728,
     * 12582912,
     *     4095,      255,     4080,       15,      240,     3840,
     *        3,       12,       48,      192,      768,     3072,
     *  37*0 /
      data eqonly /3*.true.,46*.false.,7*.true.,91*.false./
      ip = 0
      nreal = 0
      itnow = 0
1     continue
        ip = ip+1
        if (ip .gt. nn(ivx)) go to 9
11      if (nodur(ivx,ip).eq.0) then
c
c  Ignore all xtup notes except the last, the one with nodur > 0 .
c  Xtups are irrelevant here since they are already all in forced beams.
c  Will update itnow by nodur at the END of this loop
c
          ip = ip+1
          go to 11
        end if
        nreal = nreal+1
        nodue(nreal) = nodur(ivx,ip)
        short(nreal) = nodue(nreal).lt.16 .and.
     *                     .not.btest(irest(ivx,ip),0)
c
c  Rule out notes that have 'alone'-flag set
c
     *   .and..not.btest(islur(ivx,ip),18)
        ipr(nreal) = ip
        itr(nreal) = itnow
        if (nodue(nreal) .eq. 1) then
c
c  64th gap
c
          if (mod(itnow,2) .eq. 0) then
c
c  Start of 32nd gap, lump with following note
c
            ip = ip+1
		  nodue(nreal) = 1+nodur(ivx,ip)
            itnow = itnow+nodue(nreal)
          else
c
c  End of 32nd gap, lump with preceeding note
c
            nreal = nreal-1
            nodue(nreal) = 1+nodue(nreal)
            itnow = itnow+1
          end if
        else
          itnow = itnow+nodur(ivx,ip)
        end if
      go to 1
9     continue
      ir1 = 1
      itseg = lenbar/ibmrep
      do 13 irep = 1 , ibmrep
c
c  Set bitmaps for all shorts neighbored by a short. Each bit represents a
c  span of 32nd note.  maps, mapm, mape record start, full duration, and end
c  of consecutive span of beamable (<1/4) notes.
c
        maps = 0
        mapm = 0
        mape = 0
        itend = itseg*irep
        itoff = itend-itseg
        do 2 ir = ir1 , nreal
          it2 = itr(ir)+nodue(ir)-2
          if (it2 .ge. itend) then
            ir1 = ir
            go to 14
          end if
c         if (short(ir).and.((ir.gt.1.and.short(ir-1)).or.(ir.lt.nreal
          if (short(ir).and.((ir.gt.1.and.short(max(ir-1,1))).or.
     *          (ir.lt.nreal.and.short(ir+1)))) then
            ib1 = (itr(ir)-itoff)/2
            ib2 = (it2-itoff)/2
            if (max(ib1,ib2).gt.47 .or. ir.gt.48 .or.
     *                       min(ib1,ib2).lt.0) return
c
c  Must have an odd number obe beats in a long bar.  Auto-beam won't work
c
            nip1(ib1) = ipr(ir)
            nip2(ib2) = ipr(ir)
c
c  nip1,2(ib) = 0 unless a real note starts,ends on bit ib; then = ip
c
            maps = ibset(maps,ib1)
            mape = ibset(mape,ib2)
            do 3 ib = ib1 , ib2
              mapm = ibset(mapm,ib)
3           continue
          end if
2       continue
14      continue
        if (mapm .eq. 0) go to 13
c
c  Zero out bits from forced beams
c
        maps = iand(maps,not(mapfb(irep)))
        mapm = iand(mapm,not(mapfb(irep)))
        mape = iand(mape,not(mapfb(irep)))
c
c  Compare map with template.
c
        do 4 it = 1 , nummask(ibmtyp)
          masknow = mask(it,ibmtyp)
          if (iand(masknow,mapm) .eq. masknow) then
c
c  Find least significant bit in the mask to check start time
c
            mtemp = masknow
            maskm = masknow
            do 5 is1 = 0 , 47
              if (iand(1,mtemp) .eq. 1) go to 6
              mtemp = ishft(mtemp,-1)
5           continue
6           continue
            if (iand(ishft(1,is1),maps) .eq. 0) go to 4
c
c  is1 is the bit where the beam starts.  Continue shifting to
c  find most significant bit in the mask to check ending time
c
            do 7 is2 = is1 , 47
              mtemp = ishft(mtemp,-1)
              if (iand(1,not(mtemp)) .eq. 1) go to 8
7           continue
8           continue
c
c  is2 is now the bit on which the beam ends.
c
            if (iand(ishft(1,is2),mape) .eq. 0) go to 4
c
c  Did we pick out a single note from the middle of a longer sequence?
c
            if (nip1(is1) .eq. nip2(is2)) go to 4
c
c  We almost have a beam.  Check equality of notes if needed.
c
            if (eqonly(it,ibmtyp)) then
              do 10 ip = nip1(is1) , nip2(is2)
                if (nodur(ivx,ip) .ne. 8) then
c
c  There is a non-1/8th note in this beam. Exit if not 2 quarters
c
                  if (is2-is1 .ne. 15) go to 4
c
c  Beam is 2 quarters long.  Check if can split in half.
c
                  ithalf = 0
                  do 20 iip = nip1(is1) , nip2(is2)
                    ithalf = ithalf+nodur(ivx,iip)
                    if (ithalf .gt. 16) go to 4
                    if (ithalf .eq. 16) go to 21
20                continue
                  print*,'Problem in findbeam, please call Dr. Don'
                  go to 4
21                continue
c
c  Otherwise, split in half by keeping only the first half.  Other half will
c  be picked up later, assuming masks are listed longest first.
c
                  is2 = is1+7
c
c  Reset maskm (since only used part of mask), used later to zero out
c  bits that contain beams
c
                  maskm = 0
                  do 15 is = is1 , is2
                    maskm = ibset(maskm,is)
15                continue
                  go to 16
                end if
10            continue
            end if
16          continue
c
c  This is a beam.  If last "effective" ends on odd 64th, add 1 more
c
c            if (abs(mod(to(iand(255,ipl(ivx,nip2(is2))))
c     *           +nodur(ivx,nip2(is2)),2.)) .gt. tol) then
            if (abs(amod(to(iand(255,ipl(ivx,nip2(is2))))
     *           +nodur(ivx,nip2(is2))+.5*tol,2.)) .gt. tol) then
              nip2(is2) = nip2(is2)+1
            end if
            numbms(ivx) = numbms(ivx)+1
            numnew = numbms(ivx)
            call logbeam(numnew,nip1(is1),nip2(is2))
c
c  Zero out the appropriate bits so these notes don't get used again
c
            mapm = iand(mapm,not(maskm))
            if (mapm.eq.0) go to 13
            maps = iand(maps,not(maskm))
            mape = iand(mape,not(maskm))
          end if
4       continue
13    continue
      return
      end
      subroutine logbeam(numnew,nip1,nip2)
      parameter (nm=12)
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      common /comfb/ nfb(nm),t1fb(nm,20),t2fb(nm,20),ulfbq(nm,20),ifb
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*1 ulq,sepsymq,sq,ulfq,ulfbq
      logical beamon,firstgulp,figbass,figcheck,isfig,isxtup,btest
      ibm1(ivx,numnew) = nip1
      ibm2(ivx,numnew) = nip2
      numnow = numnew
      if (numnew .gt. 1) then
c
c  If it starts before any others, must put it in order
c
        do 11 ib = numnew-1 , 1 , -1
          if (ibm1(ivx,ib) .lt. nip1) go to 12
          ibm1(ivx,ib+1) = ibm1(ivx,ib)
          ibm2(ivx,ib+1) = ibm2(ivx,ib)
          ulq(ivx,ib+1) = ulq(ivx,ib)
          ibm1(ivx,ib) = nip1
          ibm2(ivx,ib) = nip2
          numnow = ib
11      continue
12      continue
      end if
      sum = 0.
c
c Beam has non-xtup within
c
      nrests = 0
      isxtup = .false.
      do 9 iip = nip1 , nip2
        if (btest(islur(ivx,nip1),21)) then
c
c  Forced multiplicity
c
          mult(ivx,iip) = igetbits(islur(ivx,nip1),3,22)
        else if (.not.isxtup) then
          if (nodur(ivx,iip) .gt. 0) then
            mult(ivx,iip) = 4-log2(nodur(ivx,iip))
          else
c
c  Start xtup within forced beam
c
            isxtup = .true.
            iip1 = iip
          end if
        else if (isxtup .and. nodur(ivx,iip).gt.0) then
c
c  End of xtup within forced beam
c
          multx = int(10.5+2.929+(0.952*alog(1.+iip-iip1)-
     *                   alog(nodur(ivx,iip)/2.))/0.69315)-10
          do 74 iiip = iip1 , iip
            mult(ivx,iiip) = multx
74        continue
          isxtup = .false.
        end if
        if (btest(irest(ivx,iip),0)) then
          nrests = nrests+1
        else
          sum = sum+nolev(ivx,iip)
        end if
9     continue
c
c  Set beam up-down-ness
c
      if (ifb.gt.0 .and. ulfbq(ivx,max(1,ifb)).ne.'x') then
        ulq(ivx,ifb) = ulfbq(ivx,ifb)
c
c  This probably works only because forced beams are done first, so they
c  don't have to be re-sorted within each voice. ????
c
      else if (nvmx(iv) .eq. 2) then
c
c  Multi-voice per staff
c
        if (ivx .le. nv) then
          ulq(ivx,numnow) = 'l'
        else
          ulq(ivx,numnow) = 'u'
        end if
      else
c
c  Defaults
c
        ulq(ivx,numnow) =
c    *      ulfq(sum/(nip2-nip1+1),ncmid(iv,nip1))
     *      ulfq(sum/(nip2-nip1+1-nrests),ncmid(iv,nip1))
      end if
      return
      end
      character*1 function ulfq(xnolev,ncm)
c
c  Stem directions
c
      common /combc/ bcspec
      logical bcspec
        test = xnolev-ncm
        if (test.lt.-.001 .or.
     *         (test.lt..001.and.bcspec.and.ncm.eq.23) ) then
          ulfq = 'u'
        else
          ulfq = 'l'
        end if
      return
      end
      character*1 function udfq(nolev,ncm)
c
c  Slur directions
c
      common /combc/ bcspec
      logical bcspec
        ntest = nolev-ncm
        if (ntest.lt.0 .or.
     *         (ntest.eq.0 .and. bcspec .and. ncm.eq.23) ) then
          udfq = 'd'
        else
          udfq = 'u'
        end if
      return
      end
      function numclef(clefq)
c
c  Returns the number to be used as argument of \setclef (for MusiXTeX only)
        character*1 clefq
c        if (ichar(clefq) .lt. 55) then
        if (ichar(clefq) .le. 55) then
          numclef = ichar(clefq)-48
          if (numclef .eq. 7) numclef = 9
        else
          numclef = index('tsmanrbxxf',clefq)-1
        end if
      return
      end
      function feon(time)
        common /comeon/ eonk,ewmxk
        feon = sqrt(time/2)**(1.-eonk)*ewmxk
      return
      end
      subroutine setmeter(mtrnuml,mtrdenl,ibmtyp,ibmrep)
c
c  Sets last 2 args depending on 1st 2, (logical) num, denom.
c  ibmtyp = 1, 2, or 3 defines set of masks for beam groupings.
c  1: all duple meters
c  2: triple w/ denom=4, subdivide in groups of 2 8ths
c  3: triple w/ denom=8, subdivide in groups of 3 8ths
c  Note that lenbar is set at top or when 'm' symbol is read in getnote
c
      if (mtrdenl .eq. 4) then
        if (mod(mtrnuml,3) .eq. 0) then
          ibmtyp = 2
          ibmrep = mtrnuml/3
        else
          ibmtyp = 1
          ibmrep = mtrnuml/2
        end if
      else if (mtrdenl .eq. 2) then
        ibmtyp = 1
        if (mtrnuml .eq. 3) then
          ibmrep = 3
        else
          ibmrep = 2*mtrnuml/mtrdenl
        end if
      else
c
c  Assumes mtrdenl=8 and 3/8, 6/8, 9/8, or 12/8
c
        ibmtyp = 3
        ibmrep = mtrnuml/3
      end if
c
c  Reset so we don't keep writing new meters
c
      mtrnuml = 0
c
c  Prevent ibmrep=0.  Needed for odd bars, e.g. 1/8, where beams don't matter
c
      ibmrep = max(ibmrep,1)
      return
      end
      subroutine wgmeter(mtrnmp,mtrdnp)
c
c  Writes meter stuff to file 11, so only called if islast=.true.
c
      character*1 sq,chax
      if (mtrdnp .eq. 0) return
      sq=chax(92)
      if (mtrnmp.gt.0 .and. mtrnmp.le.9) then
        if (mtrdnp .lt. 10) then
          write(11,'(a25,i1,a2,i1,a3)')
     *           sq//'generalmeter{'//sq//'meterfrac{',
     *           mtrnmp,'}{',mtrdnp,'}}%'
        else
          write(11,'(a25,i1,a2,i2,a3)')
     *           sq//'generalmeter{'//sq//'meterfrac{',
     *           mtrnmp,'}{',mtrdnp,'}}%'
        end if
      else if (mtrnmp .ge. 10) then
        if (mtrdnp .lt. 10) then
          write(11,'(a25,i2,a2,i1,a3)')
     *           sq//'generalmeter{'//sq//'meterfrac{',
     *           mtrnmp,'}{',mtrdnp,'}}%'
        else
          write(11,'(a25,i2,a2,i2,a3)')
     *           sq//'generalmeter{'//sq//'meterfrac{',
     *           mtrnmp,'}{',mtrdnp,'}}%'
        end if
      else if (mtrnmp .lt. 0) then
        write(11,'(a26,i1,a2,i1,a3)')
     *           sq//'generalmeter{'//sq//'meterfracS{',
     *           -mtrnmp,'}{',mtrdnp,'}}%'
      else if (mtrdnp .le. 4) then
          write(11,'(a21,i1,a2)')
     *             sq//'generalmeter{'//sq//'meterN',mtrdnp,'}%'
      else if (mtrdnp .eq. 5) then
        write(11,'(a)')sq//'generalmeter'//sq//'allabreve%'
      else if (mtrdnp .eq. 6) then
        write(11,'(a)')sq//'generalmeter'//sq//'meterC%'
      else if (mtrdnp .eq. 7) then
        write(11,'(a)')sq//'generalmeter'//sq//'meterIIIS%'
      end if
      return
      end
      function upcaseq(chq)
      character*1 chq,upcaseq,chax
        if (ichar(chq).ge.61.and.ichar(chq).lt.122) then
          upcaseq = chax(ichar(chq)-32)
        else
          upcaseq = chq
          print*,'Warning, upcaseq was called with improper argument: '
     *            //chq
      stop
        end if
      return
      end
      subroutine addblank(noteq,lnoten)
      character*8 noteq
      character*1 tchar
      tchar = noteq
      noteq = ' '//tchar
      lnoten = 2
      return
      end
      subroutine doslur(nolev,isdat1,isdat2,isdat3,nsdat,ip,iv,kv,nv,
     *     beamon,ncm,soutq,lsout,ulq,islur,ipl,iornq,islhgt,tno,nacc)
c
c  Called once per main note.
c
      parameter (nm=12,mv=24576)
      integer*4 isdat1(202),isdat2(202),isdat3(202)
      common /comslur/ listslur,upslur(nm,2),ndxslur
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      common /comsln/ is1n1,is2n1,irzbnd,isnx
      character*1 ulq,slurudq,udfq,udqq,chax
      character*79 notexq
      character*8 noteq
      character*80 soutq
      logical upslur,beamon,btest,stemup,iscrd,sfound,tfound,tmove,
     *        settie
      logical slmon,dbltie
      common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
     *       naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
     *       slmon(0:nm),dbltie
      integer*2 mmidi
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
c
c  Bits in isdat1:
c  13-17    iv
c  3-10     ip
c  11       start/stop switch
c  12       kv-1
c  19-25    ichar(code$)
c  26       force direction?
c  27       forced dir'n = up if on, set in sslur; also
c           final direction, set in doslur when beam is started, used on term.
c  28-31    ndxslur, set in doslur when beam is started, used on term.
c
c  Bits in isdat2
c  0        Chord switch.  Not set on main note.
c  1-2      left/right notehead shift.  Set only for chord note.
c  3        tie positioning
c  4        dotted flag
c  6-11     voff1 1-63  =>  -31...+31
c  12-18    hoff1 1-127 => -6.3...+6.3
c  19-25    nolev
c
c  Bits in isdat3: Only used for slur endings
c  0        set if midslur (at least one argument)
c  1        set if curve (2 more args)
c  2-7      32+first arg (height correction) (1st arg may be negative)
c  8-10     second arg (initial slope)
c  11-13    third arg (closing slope)
c
c  In listslur bit ib is on if slur index ib is in use, ib=0-8.
c  ndxslur = slur index
c  Height of slur is nole+ivoff+iupdn.  iupdn is +/-1 if t&s slurs on same note,
c  s-slur is blank (idcode=32), t-slur is idcode=1.
c  ivoff is user-defined shift or shift due to . or _ , or chord adjustment.
c  Ivoff will be set for ./_ only if no user-defined shift is specified.
c  If highest note has upslur, save slur height in islhgt in case
c  ornament must be moved.
c
      islhgt = 0
      if (beamon) then
        stemup = ulq .eq. 'u'
      else if (nvmx(iv) .eq. 2) then
        if (.not.btest(islur,30)) then
c
c  Single note, 2 lines of music, stem direction not forced
c
          stemup = ivx .gt. nv
        else
          stemup = btest(islur,17)
        end if
      else
        stemup = udqq(nolev,ncm,islur,nvmx(iv),ivx,nv) .eq. 'u'
      end if
      iscrd = btest(ipl,10)
      if (btest(islur,1)) then
c
c  't'-slur (idcode=1) somewhere on this note.  Find it, check height against
c    's'-slur (idcode=32)
c
        sfound = .false.
        tfound = .false.
        tmove = .false.
        do 5 isdat = 1 , nsdat
          if (iv .eq. igetbits(isdat1(isdat),5,13) .and.
     *          ip .eq. igetbits(isdat1(isdat),8,3) .and.
     *              kv .eq. igetbits(isdat1(isdat),1,12)+1) then
            if (.not.tfound) then
              tfound = igetbits(isdat1(isdat),7,19).eq.1
              if (tfound) then
                nolevt = igetbits(isdat2(isdat),7,19)
                isdatt = isdat
                if (sfound) go to 6
              end if
            end if
            if (.not.sfound) then
              sfound = igetbits(isdat1(isdat),7,19).eq.32
              if (sfound) then
                nolevs = igetbits(isdat2(isdat),7,19)
                isdats = isdat
                if (tfound) go to 6
              end if
            end if
          end if
5       continue
c
c  Will come thru here if there is a t with no s, so comment out the following
c        print*,'Did not find s+t-slurs in doslur'
c
6       continue
        if (sfound .and. tfound)
     *    tmove = nolevs.eq.nolevt .and.
c
c  Check if 2 starts or two stops
c
     *     ((btest(isdat1(isdats),11).and.btest(isdat1(isdatt),11)) .or.
     *      (.not.btest(isdat1(isdats),11).and.
     *                               .not.btest(isdat1(isdatt),11)) )
c
c  This is a flag for later changing slur level, after we know slur dir'n.
c
      end if
      if (ismidi) then
        settie = .false.
        dbltie = .false.
      end if
      do 1 isdat = 1 , nsdat
        isdata = isdat1(isdat)
        if (iv .eq. igetbits(isdata,5,13) .and.
     *      ip .eq. igetbits(isdata,8,3) .and.
     *            kv .eq. igetbits(isdata,1,12)+1) then
c
c  Since iv and kv match, ivx will be correct
c
          idcode = igetbits(isdata,7,19)
          ivoff = igetbits(isdat2(isdat),6,6)-32
          ihoff = igetbits(isdat2(isdat),7,12)-64
          iupdn = 0
          slurudq = 'd'
          nolevs = igetbits(isdat2(isdat),7,19)
          if (btest(isdata,11)) then
c
c  Turnon, so get slur direction
c
            if (btest(isdata,26)) then
c
c  Force slur direction
c
              if (btest(isdata,27)) slurudq = 'u'
            else if (nvmx(iv) .eq. 1) then
c
c  Only one voice per line
c
              if (.not.beamon) then
c
c  Separate note.
c
                slurudq = udfq(nolev,ncm)
              else
c
c  In a beam
c
                if (ulq .ne. 'u') slurudq = 'u'
              end if
              if (iscrd) then
                if (nolevs .gt. ncm) then
                  slurudq = 'u'
                else
                  slurudq = 'd'
                end if
              end if
            else
c
c  Two voices per line.  Get default
c
              if (ivx .gt. nv) slurudq = 'u'
c
c  Upper voice of the two, so up slur
c
            end if
c
c  Save up/down-ness for use at termination
c
            if (slurudq .eq. 'u') isdata = ibset(isdata,27)
c
c  End of section for setting slur direction, still in "Turnon" if-block.
c
            if (idcode.eq.1 .and. tmove) then
              iupdn = 1
              if (slurudq .eq. 'd') iupdn = -1
            end if
            if (btest(iornq,11).or.btest(iornq,12)) then
c
c  Raise or lower slur by one unit provided . or _ is on same side as slur
c
              if ((stemup .and. slurudq.eq.'d') .or.
     *             (.not.stemup .and. slurudq.eq.'u')) then
c
c  Must move the slur for _ or .
c
                if (stemup) then
                  ivoffinc = -1
                else
                  ivoffinc = 1
                end if
                if (((stemup      .and. nolev.ge.ncm-2) .or.
     *              (.not.stemup .and. nolev.le.ncm+2)) .and.
     *                mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
                ivoff = ivoff+ivoffinc
              end if
            end if
c            if (listslur .eq. 511) then
            if (listslur .eq. 4095) then
              print*
              print*,'You defined the thirteenth slur, one too many!'
              write(15,'(/,a)')
     *               'You defined the thirteenth slur, one too many!'
              stop 1
            end if
c
c  Get index of next slur not in use, starting from 8 down
c
c            ndxslur = log2(511-listslur)
            ndxslur = log2(4095-listslur)
c
c  Record slur index
c
            listslur = ibset(listslur,ndxslur)
c
c  Save for use on termination
c
            call setbits(isdata,4,28,ndxslur)
c
c  Shift for stem?
c
c            if (stemup .and. slurudq.eq.'u') ihoff = ihoff+8
            if (stemup .and. slurudq.eq.'u' .and. tno.lt.63.) 
     *              ihoff = ihoff+8
            if (btest(isdat2(isdat),3)) then
c
c  Tie spacing, (slur start)
c
              if (slurudq.eq.'d') then
                ivoff = ivoff+1
                ihoff = ihoff+8
              else if (slurudq.eq.'u') then
                ivoff = ivoff-1
c                if (.not.stemup) ihoff = ihoff+8
                if (.not.(stemup.and.tno.lt.63.)) ihoff = ihoff+8
c
c  (already shifted if (stemup.and.tno.gt.63.) and slurudq='u')
c
              end if
            end if
            if (iscrd) then
c
c  Additional horiz shifts for h-shifted noteheads?
c
              if (btest(isdat2(isdat),1)) then
c
c  Slur start on left-shifted chord notehead.  ASSUME downstem.
c
                if (nolevs.eq.minlev .and. slurudq.eq.'d') then
                  ihoff = ihoff-2
                else
                  ihoff = ihoff-10
                end if
              else if (btest(isdat2(isdat),2)) then
c
c  Right shifted chord notehead.  ASSUME upstem.
c
                if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
                  ihoff = ihoff+2
                else
                  ihoff = ihoff+10
                end if
              end if
            end if
            if (ihoff .eq. 0) then
c
c  Write stuff for non-shifted start
c
              notexq = chax(92)//'islur'//slurudq
              lnote = 7
            else
              notexq = chax(92)//'is'//slurudq
              lnote = 4
            end if
            if (btest(isdat2(isdat),4)) then
c
c  Dotted slur
c
              noteq = notexq
              notexq = chax(92)//'dotted'//noteq
              lnote = lnote+7
            end if
c
c  Add slur index to string
c
            if (ndxslur .lt. 10) then
              notexq = notexq(1:lnote)//chax(48+ndxslur)
              lnote = lnote+1
            else
              notexq = notexq(1:lnote)//'{1'//chax(38+ndxslur)//'}'
              lnote = lnote+4
            end if
c
c  Add note name to string
c
            call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
            notexq = notexq(1:lnote)//noteq(1:lnoten)
            lnote = lnote+lnoten
c
c  Save height (for ornament and barnobox interference) if topmost slur is up
c
            if (slurudq.eq.'u' .and.
     *           (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
              islhgt = nolevs+iupdn+ivoff
c
c  Save height & idcode if top voice and slur start
c
              if (ivx.eq.ivmx(nv,nvmx(nv)) .and. islhgt.gt.is1n1) then
                is1n1 = islhgt
                is2n1 = idcode
              end if
            end if
            if (ihoff .ne. 0.) then
              shift = ihoff*0.1
              notexq = notexq(1:lnote)//'{'
              lnote = lnote+1
              lform = lfmt1(shift)
              write(notexq(lnote+1:lnote+lform),'(f'//
     *                  chax(48+lform)//'.1)') shift
              lnote = lnote+lform
              notexq = notexq(1:lnote)//'}'
              lnote = lnote+1
            end if
            call addstr(notexq,lnote,soutq,lsout)
c
c  Zero out ip1 to avoid problems if slur goes to next input blk.
c
            call setbits(isdata,8,3,0)
c
c  Set slur-on data for midi.  Only treat null-index slurs for now.
c
            if (ismidi .and. idcode.eq.32) then
c              levson(midchan(iv,kv)) = nolev
              levson(midchan(iv,kv)) = nolevs
              if (settie) dbltie = .true.
c
c  Only way settie=T is if we just set a tie ending.  So there's also a slur
c   start here, so set a flag telling addmidi not to zero out levson
c 
            end if
          else
c
c  Slur is ending.  Back thru list to find starting slur
c
            do 3 j = isdat-1 , 1 , -1
              if (iv.eq.igetbits(isdat1(j),5,13) .and.
     *            kv.eq.igetbits(isdat1(j),1,12)+1) then
                if (idcode .eq. igetbits(isdat1(j),7,19)) then
                  ndxslur = igetbits(isdat1(j),4,28)
                  if (btest(isdat1(j),27)) slurudq = 'u'
                  go to 4
                end if
              end if
3           continue
            print*,'Bad place in doslur'
            stop 1
4           continue
            if (btest(isdat3(isdat),0)) then
c
c  Deal with \curve or \midslur
c
              if (btest(isdat3(isdat),1)) then
                notexq = chax(92)//'curve'
                lnote = 6
              else
                notexq = chax(92)//'midslur'
                lnote = 8
              end if
              imid = igetbits(isdat3(isdat),6,2)-32 
              if (imid.lt.0 .or. imid.gt.9) then
c
c  Need brackets
c
                notexq = notexq(1:lnote)//'{'
                lnote = lnote+1
                if (imid .lt. -9) then
                  write(notexq(lnote+1:lnote+3),'(i3)')imid
                  lnote = lnote+3
                else if (imid.lt.0 .or. imid.gt.9) then
                  write(notexq(lnote+1:lnote+2),'(i2)')imid
                  lnote = lnote+2
                else
                  write(notexq(lnote+1:lnote+1),'(i1)')imid
                  lnote = lnote+1
                end if
                notexq = notexq(1:lnote)//'}'
                lnote = lnote+1
              else
c
c  1=<imid=<9, no brackets
c
                notexq = notexq(1:lnote)//char(48+imid)
                lnote = lnote+1
              end if
              if (btest(isdat3(isdat),1)) then
c
c  \curve; 3 args
c
                notexq = notexq(1:lnote)
     *                      //char(48+igetbits(isdat3(isdat),3,8))
                notexq = notexq(1:lnote+1)
     *                      //char(48+igetbits(isdat3(isdat),3,11))
                lnote = lnote+2
              end if 
              call addstr(notexq,lnote,soutq,lsout)
            end if
c
c  Shift slur ending for stem on any note?
c
c            if (.not.stemup .and. slurudq.eq.'d') ihoff = ihoff-8
            if (.not.stemup .and. slurudq.eq.'d' .and. tno.lt.63.) 
     *                ihoff = ihoff-8
            if (btest(isdat2(isdat),3)) then
c
c  Shift ending for tie spacing
c
              if (slurudq .eq. 'u') then
                ihoff = ihoff-8
                ivoff = ivoff-1
              else if (slurudq .eq. 'd') then
                ivoff = ivoff+1
c                if (stemup) ihoff = ihoff-8
                if (stemup.or. tno.gt.63.) ihoff = ihoff-8
              end if
            end if
            if (iscrd) then
c
c  Shift termination for shifted notehead?
c
              if (btest(isdat2(isdat),1)) then
c
c  Left-shifted chord notehead.  ASSUME downstem.
c
                if (nolevs.eq.minlev .and. slurudq.eq.'d') then
                  ihoff = ihoff-2
                else
                  ihoff = ihoff-10
                end if
              else if (btest(isdat2(isdat),2)) then
c
c  Right shifted chord notehead.  ASSUME upstem.
c
                if (nolevs.eq.maxlev .and. slurudq.eq.'u') then
                  ihoff = ihoff+2
                else
                  ihoff = ihoff+10
                end if
              end if
            end if
            if (ihoff .eq. 0) then
              notexq = chax(92)//'tslur'
              lnote = 6
            else
c
c  Shift needed
c
              notexq = chax(92)//'ts'
              lnote = 3
            end if
            if (ndxslur .lt. 10) then
              notexq = notexq(1:lnote)//chax(48+ndxslur)
              lnote = lnote+1
            else
              notexq = notexq(1:lnote)//'{1'//chax(38+ndxslur)//'}'
              lnote = lnote+4
            end if
            if (btest(iornq,11).or.btest(iornq,12)) then
c
c  Raise or lower slur by one unit provided . or _ is on same side as slur
c
              if ((stemup .and. slurudq.eq.'d') .or.
     *                 (.not.stemup .and. slurudq.eq.'u')) then
                if (stemup) then
                  ivoffinc = -1
                else
                  ivoffinc = 1
                end if
                if (((stemup .and. nolev.ge.ncm-2) .or.
     *              (.not.stemup .and. nolev.le.ncm+2)) .and.
     *               mod(abs(ncm-nolev),2).eq.0) ivoffinc = 2*ivoffinc
              end if
              ivoff = ivoff+ivoffinc
            end if
            if (idcode.eq.1 .and. tmove) then
c
c  t-slur height adjustment
c
              iupdn = 1
              if (slurudq .eq. 'd') iupdn = -1
            end if
            call notefq(noteq,lnoten,nolevs+iupdn+ivoff,ncm)
            if (slurudq.eq.'u' .and.
     *           (.not.btest(isdat2(isdat),0).or.nolevs.eq.maxlev)) then
              islhgt = nolevs+iupdn+ivoff
c
c  If topvoice, upslur, and idcode checks, no more need to keep hgt for barno.
c
              if (ivx.eq.ivmx(nv,nvmx(nv)) .and. is1n1.gt.0) then
                if (idcode .eq. is2n1) is1n1=0
              end if
            end if
            notexq = notexq(1:lnote)//noteq(1:lnoten)
            lnote = lnote+lnoten
            if (ihoff .ne. 0) then
              shift = ihoff*0.1
              notexq = notexq(1:lnote)//'{'
              lnote = lnote+1
              lform = lfmt1(shift)
              write(notexq(lnote+1:lnote+lform),
     *            '(f'//chax(48+lform)//'.1)')shift
              lnote = lnote+lform
              notexq = notexq(1:lnote)//'}'
              lnote = lnote+1
            end if
            call addstr(notexq,lnote,soutq,lsout)
c
c  Clear the bit from list of slurs in use
c
            listslur = ibclr(listslur,ndxslur)
c
c  Zero out the entire strings for start and stop
c
            isdata = 0
            isdat2(isdat) = 0
            isdat1(j) = 0
            isdat2(j) = 0
            isdat3(isdat) = 0
c
c  Set midi info for slur ending
c
            if (ismidi .and. idcode .eq. 32) then  
              icm = midchan(iv,kv)
              if (slmon(icm)) then
c                if (nolev.eq.levson(icm) .and. iand(7,nacc).eq.0) then
                if (nolevs.eq.levson(icm) .and. iand(7,nacc).eq.0) then
c
c  There is a tie here.  NB!!! assumed no accidental on 2nd member of tie.
c
c                  levsoff(icm) = nolev
                  levsoff(icm) = nolevs
                  settie = .true.
                else
                  levsoff(icm) = 0
                  levson(icm) = 0
                  slmon(icm) = .false.
                end if
              end if
            end if 
          end if
          isdat1(isdat) = isdata
        end if
1     continue
c
c  Clear and collapse the slur data list
c
      numdrop = 0
      do 2 isdat  = 1 , nsdat
        if (isdat1(isdat) .eq. 0) then
          numdrop = numdrop+1
        else if (numdrop .gt. 0) then
          isdat1(isdat-numdrop) = isdat1(isdat)
          isdat2(isdat-numdrop) = isdat2(isdat)
          isdat3(isdat-numdrop) = isdat3(isdat)
          isdat1(isdat) = 0
          isdat2(isdat) = 0
          isdat3(isdat) = 0
        end if
2     continue
      nsdat = nsdat-numdrop
c      call report(nsdat,isdat1,isdat2)
      return
      end
      subroutine addfb(nfb,iv,tnew,t1fb,t2fb,ulfbq,ifbadd)
      parameter (nm=12)
      integer nfb(nm)
      common /comtol/ tol
      real*4 t1fb(nm,20),t2fb(nm,20)
      character*1 ulfbq(nm,20)
      ifbadd = 1
      nfb(iv) = nfb(iv)+1
      do 1 ifb = nfb(iv)-1 , 1 , -1
        if (tnew .lt. t1fb(iv,ifb)-tol) then
          t1fb(iv,ifb+1) = t1fb(iv,ifb)
          t2fb(iv,ifb+1) = t2fb(iv,ifb)
          ulfbq(iv,ifb+1) = ulfbq(iv,ifb)
        else
          ifbadd = ifb+1
          go to 2
        end if
1     continue
2     continue
      t1fb(iv,ifbadd) = tnew
      ulfbq(iv,ifbadd) = 'x'
      return
      end
      subroutine addask(taskn,waskn,elaskn,
     *                  fixednew,scaldold,tglp1,isudsp)
      parameter (nm=12)
      logical isudsp
      common /comas1/ naskb,task(20),wask(20),elask(20)
      common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
      common /comtol/ tol
      if (isudsp) then
c
c  Find which udsp we're dealing with
c
        do 1 iudsp = 1 , nudsp
          if (abs(taskn+tglp1-tudsp(iudsp)) .lt. tol) go to 2
1       continue
        print*,'You should note BEEE here in addask!'
        stop 1
2       continue
c
c  Fixednew and scaldold must not be changed, since udsp's are already included
c  in fsyst from pmxa, and udsp don't involve scaled space..
c
        if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then
c
c  Must add user-defined space to what's there already.
c
          wask(naskb) = wask(naskb)+udsp(iudsp)
        else
c
c  This place has no other space.
c
          naskb = naskb+1
          task(naskb) = taskn
          wask(naskb) = udsp(iudsp)
          elask(naskb) = 0.
        end if
      else
c
c  This is a normal space, no effect if smaller than existing space
c
        if (naskb.gt.0 .and. abs(taskn-task(max(1,naskb))).lt.tol) then
c
c  We already put in some space at this time
c  Check if new one needs more space than old one at same time
c
          if (waskn .gt. wask(naskb)) then
            naskb = naskb-1
          else
            return
          end if
        end if
        naskb = naskb+1
        task(naskb) = taskn
        wask(naskb) = waskn
        elask(naskb) = elaskn
        fixednew = fixednew+waskn
        scaldold = scaldold+elaskn
      end if
      return
      end
      subroutine askfig(pathnameq,lpath,basenameq,lbase,figbass,istype0)
      logical figbass,ispoi,topmods,istype0,done
      common /comhsp/ hpttot(176)
      common /compoi/ ispoi
      common /comas3/ ask(1400),iask,topmods
      character*40 pathnameq
      character*24 basenameq
      character*1 sq,chax
      character*129 outq
      sq = chax(92)
      open(12,file=pathnameq(1:lpath)//basenameq(1:lbase)//'.tex')
c
c  Transfer first 5 lines of main internal TeX file
c
      do 11 il = 1 , 5
        call moveln(11,12,done)
11    continue
      if (istype0) then
c
c  Transfer literal TeX stuff from special scratch file
c
        rewind(17)
10      call moveln(17,12,done)
        if (.not.done) go to 10
        close(17)
      end if
c
c  Transfer next 2 lines from main scratch file
c
      do 3 il = 1 , 2
        call moveln(11,12,done)
3     continue
      if (ispoi) write(12,'(a)')sq//'input musixpoi'
      if (figbass) then
c
c  Transfer .fig data from scratch (unit 14) into external .tex (unit 12)
c
4       call moveln(14,12,done)
        if (.not.done) go to 4
        close(14)
      end if
      iask = 0
      ihs = 0
1     read(11,'(a129)',end=999)outq
c
c  Hardspaces.
c
      if (outq(1:5) .eq. sq//'xard') then
        ihs = ihs+1
        outq(2:2) = 'h'
        write(outq(12:15),'(f4.1)')hpttot(ihs)
        lenout = 19
        go to 9
      end if
c
c  This part hard-wires ask's into new .tex file as ast's
c
2     indxask = index(outq,sq//'ask')
      if (indxask .ne. 0) then
        iask = iask+1
        call putast(ask(iask),indxask,outq)
        go to 2
      end if
      lenout = llen(outq,129)
9     continue
      write(12,'(a)')outq(1:lenout)
c
c  If this is the line with "readmod", check for topmods.
c
      if (topmods .and. outq(2:8).eq.'readmod') then
        topmods = .false.
        rewind(16)
        do 7 il = 1 , 1000
          read(16,'(a129)',end=8)outq
          lenout = llen(outq,129)
c
c  We inserted the '%' in subroutine littex, to guarantee including blank.
c
          write(12,'(a)')outq(1:lenout)
7       continue
8       continue
        close(16)
      end if
      go to 1
999   close(11)
      close(12)
      return
      end
      function llen(strq,n)
        character*129 strq
        do 1 llen = n , 0 , -1
          if (strq(llen:llen) .ne. ' ') return
1       continue
      end
      subroutine putast(elask,indxask,outq)
      character*129 outq,tag
      character*9 fmtq
      if (elask .ge. 0.) then
        if (elask.lt.0.995) then
          lp = 3
        else if (elask .lt. 9.995) then
          lp = 4
        else
          lp = 5
        end if
        write(fmtq,'(a5,i1,a3)')'(a2,f',lp,'.2)'
      else
        lp = 5
        fmtq = '(a2,f5.1)'
      end if
c
c  Overwrite as follows:  ...xyz*ask     *lmnop... ->
c                         ...xyz*ast{.nn}*lmnop...
c                         ...xyz*ast{n.nn}*lmnop...
c                         ...xyz*ast{nn.nn}*lmnop...
c  or for negative,       ...xyz*ast{-nn.n}*lmnop...
        tag = outq(indxask+9:)
        write(outq(indxask+3:),fmtq)'t{',elask
        outq = outq(1:indxask+4+lp)//'}'//tag
      return
      end
      subroutine sslur(lineq,iccount,iv,kv,ip,isdat1,isdat2,isdat3,
     *                 nsdat,notcrd,nolev)
c
c  Reads in slur data.  Record all h/v-shifts for non-chords, user-specified
c  ones for chords.
c
c  See subroutine doslur for bit values in isdat1,2,3
c
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      integer*4 isdat1(202),isdat2(202),isdat3(202)
      logical notcrd,btest
      character*128 lineq
      character*1 durq,dumq
c      invoff = .false.
c
c  Counter for signed integers.  1st is height, 2nd is horiz, 3rd is curve
c
      numint = 0
      ivoff = 0
      ihoff = 0
      nsdat = nsdat+1
      call setbits(isdat1(nsdat),5,13,iv)
      call setbits(isdat1(nsdat),1,12,kv-1)
      call setbits(isdat1(nsdat),8,3,ip)
      isdat3(nsdat) = 0
c
c  Get id letter
c
      if (lineq(iccount:iccount) .eq. 't') then
c
c  Old-style t-slur. Use special idcode = 1
c
        idcode = 1
      else
        call getchar(lineq,iccount,durq)
        if (index('uldtb+- ',durq) .gt. 0) then
c
c  Null id
c
          idcode = 32
          iccount = iccount-1
        else
          idcode = ichar(durq)
        end if
      end if
      call setbits(isdat1(nsdat),7,19,idcode)
c
c  Set start/stop: look thru list from end for same idcode,iv,kv
c
      do 2 isdat = nsdat-1 , 1 , -1
        if (idcode .eq. igetbits(isdat1(isdat),7,19) .and.
     *      iv .eq. igetbits(isdat1(isdat),5,13) .and.
     *      kv-1 .eq. igetbits(isdat1(isdat),1,12)) then
c
c  Matched idcode & ivx.  On/off?.  If on, new is turnoff, leave bit 11 at 0.
c
          if (btest(isdat1(isdat),11)) go to 3
c
c  Found slur is a turnoff, so new one is a turnon.  Jump down to set bit
c
          go to 4
        end if
2     continue
c
c  If here, this is turnon.
c
4     continue
      isdat1(nsdat) = ibset(isdat1(nsdat),11)
3     continue
c
c  Now done with initial turnon- or turnoff-specifics.  Loop for rest of input
c
1     call getchar(lineq,iccount,durq)
      if (index('uld',durq) .gt. 0) then
c
c  Force direction
c
        isdat1(nsdat) = ibset(isdat1(nsdat),26)
        if (durq .eq. 'u') isdat1(nsdat) = ibset(isdat1(nsdat),27)
        go to 1
      else if (index('+-',durq) .gt. 0) then
        numint = numint+1
        if (numint .eq. 1) then
c
c  Vertical offset
c
          iccount = iccount+1
          call readnum(lineq,iccount,dumq,fnum)
          iccount = iccount-1
          ivoff = nint(fnum)
          if (durq .eq. '-') ivoff = -ivoff
        else if (numint .eq. 2) then
c
c  Horizontal offset
c
          iccount = iccount+1
          call readnum(lineq,iccount,dumq,fnum)
          iccount = iccount-1
c
c  fnum is abs(hshift), must be 0 to 6.3
c
          ihoff = fnum*10 + .5
          if (durq .eq. '-') ihoff = -ihoff
c
c  Later will set bits to 1...127 to represent -6.3,...+6.3
c
        else
c
c  Must be the 3rd signed integer, so it's a curve specification
c
          isdat3(nsdat) = ibset(isdat3(nsdat),0)
          iccount = iccount+1
          call readnum(lineq,iccount,dumq,fnum)
          icurv1 = nint(fnum)
          if (durq .eq. '-') icurv1 = -icurv1
          call setbits(isdat3(nsdat),6,2,32+icurv1)
          if (dumq .ne. ':') then 
c
c  Back up the pointer and loop for more input
c
            iccount = iccount-1
          else
c
c  Expect two single digits as parameters for curve
c
            isdat3(nsdat) = ibset(isdat3(nsdat),1)
            call setbits(isdat3(nsdat),3,8,
     *            ichar(lineq(iccount+1:iccount+1))-48)
            call setbits(isdat3(nsdat),3,11,
     *            ichar(lineq(iccount+2:iccount+2))-48)
            iccount = iccount+2
          end if             
        end if
        go to 1
      else if (durq .eq. 't') then
        isdat2(nsdat) = ibset(isdat2(nsdat),3)
        go to 1
      else if (durq .eq. 'b') then
        isdat2(nsdat) = ibset(isdat2(nsdat),4)
        go to 1
      end if
c
c  Record shifts
c
      call setbits(isdat2(nsdat),6, 6,ivoff+32)
      call setbits(isdat2(nsdat),7,12,ihoff+64)
c
c  Record chord flag, note level, notehead shift
c
      if (notcrd) then
        call setbits(isdat2(nsdat),7,19,nolev)
      else
        nolevc = igetbits(icrdat(ncrd),7,12)
        call setbits(isdat2(nsdat),7,19,nolevc)
        isdat2(nsdat) = ibset(isdat2(nsdat),0)
        call setbits(isdat2(nsdat),2,1,igetbits(icrdat(ncrd),2,23))
      end if
      return
      end
      subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,smed,ixrest)
c
c The outer combo algorithm
c
      parameter (nm=12)
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      character*1 ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,btest,
     *        isfig,vxtup,l1ng,l2ng,bar1syst
      real*4 slope(800),xelsk(24)
      integer ipb(24)
      common /comask/ bar1syst,fixednew,scaldold,
     *                wheadpt,fbar,poenom
      common /comas1/ naskb,task(20),wask(20),elask(20)
      common /comxtup/ ixtup,vxtup(nm),ntupv(nm),nolev1(nm),
     *                 islope(nm),xels11(24),eloff(nm)
      common /combmh/ bmhgt,clefend
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comtol/ tol
        ibc = ibmcnt(ivx)
        n1 = iand(255,ipl(ivx,ibm1(ivx,ibc)))
c
c  Set flag for xtup beam starting with rest (no others can start with rest)
c
        if (btest(irest(ivx,ipo(n1)),0)) ixrest = 1
c
c Figure how many elemskips to each note. Use the list, counting only non-rests.
c
        eskz0 = eskz(ivx,ibm1(ivx,ibc))
        nnb = 0
        sumx = 0.
        sumy = 0.
        ipxt1 = 0
        do 2 ip = ibm1(ivx,ibc) , ibm2(ivx,ibc)
          if (.not.btest(irest(ivx,ip),0)) then
            nnb = nnb+1
            ipb(nnb) = ip
            xelsk(nnb) = eskz(ivx,ip)-eskz0
            sumx = sumx+xelsk(nnb)
            sumy = sumy+nolev(ivx,ipb(nnb))
          end if
c
c  New xtup stuff here.  Final object is to get distance from start of xtup
c    to number. May also want to count xtup here, for first time.   
c
          if (ipxt1.eq.0 .and. nodur(ivx,ip).eq.0) then
c
c  Xtup is starting here
c
            ipxt1  = ip
          else if (ipxt1.gt.0 .and. nodur(ivx,ip).gt.0) then
c
c  Xtup ends here.  Set number of notes in xtup.  This may not be necessary.
c
            ntupv(ivx) = ip+1-ipxt1
c
c  Middle note of xtup if ntupv odd, note to left of gap if even.  
c
            ipxtmid = (ip+ipxt1)/2
            eloff(ivx) = eskz(ivx,ipxtmid)-eskz(ivx,ipxt1)
            if (mod(ntupv(ivx),2) .eq. 0) eloff(ivx) = eloff(ivx)+
     *                      .5*(eskz(ivx,ipxtmid+1)-eskz(ivx,ipxtmid))
            ipxt1 = 0
          end if
2       continue
        smed = 0.
        if (.not.btest(islur(ivx,ipb(1)),2)) then
c
c No forced 0 slope
c
          if (nnb .eq. 1) go to 6
          nsc = 0
          do 5 inb = 1 , nnb-1
          do 5 jnb = inb+1 , nnb
            nsc = nsc+1
            slope(nsc) = (nolev(ivx,ipb(jnb))-nolev(ivx,ipb(inb)))/
     *                   (xelsk(jnb)-xelsk(inb))
            if (abs(slope(nsc)) .lt. 1.e-4) then
              nsc = nsc+1
              slope(nsc) = slope(nsc-1)
              nsc = nsc+1
              slope(nsc) = slope(nsc-1)
            end if
5         continue
          if (nsc .eq. 1) then
            smed = slope(1)
            go to 6
          end if
          nscmid = nsc/2+1
          do 7 i = 1 , nscmid
            do 7 j = i+1 , nsc
              if (slope(j) .lt. slope(i)) then
                t = slope(j)
                slope(j) = slope(i)
                slope(i) = t
              end if
7         continue
          smed = slope(nscmid)
          if (nsc .eq. 2*(nsc/2)) then 
c
c  Even number of slopes in the list, so median is ambiguous
c
            if (abs(slope(nscmid-1)) .lt. abs(slope(nscmid))-tol) then
c
c  Lower-numbered one is truly less in absolute value, so use it
c
              smed=slope(nscmid-1)
            else if (abs(slope(nscmid-1)+slope(nscmid)) .lt. tol) then
c
c  Two slopes are effectively equal.  Take the one with sign of the average
c
              sum = 0.
              do 1 i = 1 , nsc
                sum = sum+slope(i)
1             continue
              smed = sign(smed,sum)
            end if
          end if
6         continue
          islope(ivx) = nint(0.5*smed*slfac)
          if (iabs(islope(ivx)) .gt. 9) 
     *         islope(ivx) = isign(9,islope(ivx))
        else
c
c  Forced horizontal beam
c
          islope(ivx) = 0
        end if
        beta = (sumy-islope(ivx)/slfac*sumx)/nnb
c
c  If ixrest>0, this is a virtual nolev1 at location of rest.  Will first use
c  as is for placing xtup number and/or bracket, then reset it for start of
c  actual beam
c
        nolev1(ivx) = nint(beta)
c
c  Check if any stems are too short
c
        smin = 100.
        iul = -1
        if (ulq(ivx,ibc) .eq. 'u') iul = 1
        ssq = 0.
        syb = 0.
        yb1 = nolev1(ivx)+iul*(stemlen+bmhgt*(mult(ivx,ipb(1))-1))
        do 4 inb = 1 , nnb
          ybeam = yb1+islope(ivx)*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(ivx)
          nolev1(ivx) = nint(nolev1(ivx)+iul*deficit)
          dnolev = nolev1(ivx)-nolevo
          off1 = off1+dnolev
          off2 = off2+dnolev
        end if
        ssq = ssq+2*dnolev*(syb-sumy)+dnolev**2
        if (.not.vxtup(ivx) .and. sqrt(ssq/nnb) .gt. stemmax .and.
     *    (abs(off1).lt.stemmax .or. abs(off2).lt.stemmax)
     *    .and. .not.btest(islur(ivx,ipb(1)),2)) then
c
c  The first check is to save trouble of putting xtup's in setbm2.
c  The penultimate check is that first and last stems aren't both excessive.
c  The last check is that a 0 slope has not been forced
c
          call setbm2(xelsk,nnb,sumx,sumy,ipb,islope(ivx),nolev1(ivx))
        end if
c
c  Check if beam starts or ends too high or low.
c
        xboff = bmhgt*(mult(ivx,ipb(1))-1)
        l1ng = iul*(nolev1(ivx)-ncmid(iv,ipb(1)))+xboff+7 .lt. 0.
        xnolev2 = nolev1(ivx)+islope(ivx)/slfac*xelsk(nnb)
        l2ng = iul*(xnolev2-ncmid(iv,ipb(nnb)))+xboff+7 .lt. 0
        if (l1ng .or. l2ng) then
c
c  Need to correct start or stop, also slope
c
          if (l1ng) then
            nolev1(ivx) = nint(ncmid(iv,ipb(1))-(7.+xboff)*iul)
          end if
          if (l2ng) then
            xnolev2 = nint(ncmid(iv,ipb(nnb))-(7.+xboff)*iul)
          end if
c
c  Since one or the other end has changed, need to change slope
c
          if (.not.btest(islur(ivx,ipb(1)),2))
     *       islope(ivx) = nint(slfac*(xnolev2-nolev1(ivx))/xelsk(nnb))
        end if
      return
      end
      subroutine setbm2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1)
c
c The MEAN SQUARE slope algorithm
c
      parameter (nm=12)
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      character*1 ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,
     *        isfig
      real*4 xelsk(24)
      integer ipb(24)
        ibc = ibmcnt(ivx)
        sumxx = 0.
        sumxy = 0.
        do 2 inb = 1 , nnb
          sumxx = sumxx+xelsk(inb)**2
          sumxy = sumxy+xelsk(inb)*nolev(ivx,ipb(inb))
2       continue
        delta = nnb*sumxx-sumx*sumx
        em = (nnb*sumxy-sumx*sumy)/delta
        islope = nint(0.5*em*slfac)
        if (iabs(islope) .gt. 9) islope = isign(9,islope)
        beta = (sumy-islope/slfac*sumx)/nnb
        nolev1 = nint(beta)
c
c   Check if any stems are too short
c
        smin = 100.
        iul = -1
        if (ulq(ivx,ibc) .eq. 'u') iul = 1
        do 4 inb = 1 , nnb
          ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac
          ynote = nolev(ivx,ipb(inb))
          smin = min(smin,iul*(ybeam-ynote))
4       continue
        if (smin .lt. stemmin) then
          deficit = stemmin-smin
          nolev1 = nint(nolev1+iul*deficit)
        end if
      return
      end
      function ncmid(iv,ip)
      parameter (nm=12)
      common /all/ mult(nm,200),jv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      character*1 ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,isfig
      common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
     *               ndotmv(nm),updot(nm,20),rtdot(nm,20)
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
	common /comtol/ tol
        if (ncc(iv) .eq. 1) then
          ncmid = ncmidcc(iv,1)
        else
          xtime = to(iand(255,ipl(ivx,ip)))
          do 1 icc = ncc(iv) , 1 , -1
            if (xtime .gt. tcc(iv,icc)-tol) then
              ncmid = ncmidcc(iv,icc)
              return
            end if
1         continue
          print*,'Problem in ncmid()'
          stop
        end if
      end
      subroutine clefsym(isl,notexq,lnote,nclef)
c
c  Returns string calling Don's TeX macro \pmxclef, for drawing small clefs.
c
      character*(*) notexq
      character*1 chax
        nclef = iand(ishft(isl,-12),7)
        if (nclef .eq. 0) then
c
c  treble
c
          nlev = 2
        else if (nclef .gt. 6) then
c
c  French violin
c
          nlev = 0
        else if (nclef .lt. 5) then
c
c  C-clef
c
          nlev = 2*nclef-2
        else
c
c  F-clef
c
          nlev = 2*nclef-6
        end if
        notexq = chax(92)//'pmxclef'//chax(48+min(nclef,7))
     *             //chax(48+nlev)
        lnote = 10
      return
      end
      subroutine accsym(nacc,acsymq,lacc)
      character*3 acsymq
      iacc = iand(nacc,7)
      if (iacc .eq. 1) then
        acsymq = 'fl'
        lacc = 2
      else if (iacc .eq. 2) then
        acsymq = 'sh'
        lacc = 2
      else if (iacc .eq. 3) then
        acsymq = 'na'
        lacc = 2
      else if (iacc .eq. 5) then
        acsymq = 'dfl'
        lacc = 3
      else if (iacc .eq. 6) then
        acsymq = 'dsh'
        lacc = 3
      else
        print*,'bad accidental: ',iacc
      end if
      return
      end
      subroutine littex(islur,nnl,iv,topmods,lineq,iccount)
      parameter (nm=12)
      common /comlast/ islast
      logical islast
      integer islur(nm,200)
      logical topmods
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),aftshft,
     *                nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
     *                noffseg,ngrace,nvolt,ivlit(52),iplit(52),nlit,
     *                lenlit(52),multg(37),upg(37),slurg(37),slashg(37),
     *                naccg(74),voltxtq(6),litq(52)
      logical upg,slurg,slashg,merge
      character*128 lineq,litq
      character*10 voltxtq
      character*1 durq,chax
      merge = .false.
      if (nlit .gt. 0) then
        merge = iv.eq.ivlit(nlit) .and. nnl.eq.iplit(nlit)
      end if
      nlit = nlit+1
      ivlit(nlit) = iv
      iplit(nlit) = nnl
      itype = 1
17    call getchar(lineq,iccount,durq)
      if (durq .eq. chax(92)) then
        itype=itype+1
        go to 17
      end if
      litq(nlit) = chax(92)//durq
      lenlit(nlit) = 2
18    call getchar(lineq,iccount,durq)
      if (durq.eq.chax(92)) then
        call getchar(lineq,iccount,durq)
        if (durq .ne. ' ') then
c
c  Starting a new tex command within the string
c
          litq(nlit) = litq(nlit)(1:lenlit(nlit))//chax(92)//durq
          lenlit(nlit) = lenlit(nlit)+2
          go to 18
        end if
      else
        litq(nlit) = litq(nlit)(1:lenlit(nlit))//durq
        lenlit(nlit) = lenlit(nlit)+1
        go to 18
      end if
c
c  If here, just read backslash-blank so string is done
c
      if (itype .eq. 1) then
        islur(iv,nnl) = ibset(islur(iv,nnl),16)
        if (merge) then
c
c  There are 2 separate strings on the same note, so merge them.
c
          nlit = nlit-1
          litq(nlit) = litq(nlit)(1:lenlit(nlit))
     *                //litq(nlit+1)(1:lenlit(nlit+1))
          lenlit(nlit) = lenlit(nlit)+lenlit(nlit+1)
          if (lenlit(nlit) .gt. 128) then
            print*
            print*,
     *       'Merged type-1 TeX strings longer than 128 characters'
            write(15,'(/,a)')
     *       'Merged type-1 TeX strings longer than 128 characters'
            stop 1
          end if  
        end if
      else
        if (itype .eq. 3) then
c
c  Write the string NOW
c
          if (islast)
     *          write(11,'(a)')litq(nlit)(1:lenlit(nlit))//'%'
        else
c
c  Must go at top
c
          if (.not.topmods) then
            topmods = .true.
            open(16,status='SCRATCH')
          end if
c
c  Must write '%' here rather than later, in case string ends with blank.
c
          write(16,'(a)')litq(nlit)(1:lenlit(nlit))//'%'
        end if
        nlit = nlit-1
      end if
      return
      end
      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,chax
      character*2 nofq,nofaq
      logical figcheck
        sq = chax(92)
        if (abs(offnsk) .gt. .0001) then
c
c  Write offset for floating figure, to two decimal places
c
          notexq = sq//'off{'
          if (-offnsk .lt. -9.995) then
            write(notexq(6:11),'(f6.2)')-offnsk
            lnote = 11
          else if (-offnsk.lt.-.995 .or. -offnsk.gt.9.995) then
            write(notexq(6:10),'(f5.2)')-offnsk
            lnote = 10
          else if (-offnsk.lt.-.0001 .or. -offnsk.gt..995) then
            write(notexq(6:9),'(f4.2)')-offnsk
            lnote = 9
          else
            write(notexq(6:8),'(f3.2)')-offnsk
            lnote = 8
          end if
          notexq = notexq(1:lnote)//sq//'noteskip}'
          call addstr(notexq,lnote+10,soutq,lsout)
        end if
        figq = figqq(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 = chax(nof+48)
        if (nof .gt. 9) then
          lnof = 2
          nofq = '1'//chax(nof-10+48)
        end if
        if (nofa .eq.-1) then
          lnofa = 2
          nofaq = '-1'
        else if (nofa .lt. 10) then
          lnofa = 1
          nofaq = chax(nofa+48)
        else
          lnofa = 2
          nofaq = '1'//chax(nofa+38)
        end if
        if (ch1q .eq. '0') then
c
c  Continuation figure.  Next digit is length (in noteskips)
c
          ic = ic+1
          ch2q = figq(ic:ic)
          call addstr(sq//'Cont{'//nofq(1:lnof)//'}{'//ch2q//'}',
     *           10+lnof,soutq,lsout)
        else if (ch1q.eq.'#'.or.ch1q.eq.'-'.or.ch1q.eq.'n') then
          ic = ic+1
          ch2q = figq(ic:ic)
          if (ch2q .eq. ' ') then
c
c  Figure is a stand-alone accidental, so must be centered
c
            if (ch1q .eq. '#') then
              call addstr(sq//'Figu{'//nofaq(1:lnofa)//
     *          '}{'//sq//'sharpfig}',18+lnofa,soutq,lsout)
            else if (ch1q .eq. '-') then
              call addstr(sq//'Figu{'//nofaq(1:lnofa)//
     *          '}{'//sq//'flatfig}',17+lnofa,soutq,lsout)
            else if (ch1q .eq. 'n') then
              call addstr(sq//'Figu{'//nofaq(1:lnofa)//
     *                '}{'//sq//'natfig}',16+lnofa,soutq,lsout)
            end if
            go to 2
          else
c
c  Figure is an accidental followed by a number
c  First put the accidental (offset to the left)
c
            if (ch1q .eq. '#') then
              call addstr(sq//'Figu{'//
     *               nofaq(1:lnofa)//'}{'//sq//'fsmsh}',
     *               15+lnofa,soutq,lsout)
            else if (ch1q .eq. '-') then
              call addstr(sq//'Figu{'//
     *               nofaq(1:lnofa)//'}{'//sq//'fsmfl}',
     *               15+lnofa,soutq,lsout)
            else if (ch1q .eq. 'n') then
              call addstr(sq//'Figu{'//
     *               nofaq(1:lnofa)//'}{'//sq//'fsmna}',
     *               15+lnofa,soutq,lsout)
            end if
c
c  Now put the number
c
            call addstr(sq//'Figu{'//nofq(1:lnof)//'}{'//ch2q//'}',
     *           10+lnof,soutq,lsout)
          endif
        else if (ch1q .eq. '_') then
c
c  Placeholder only (for lowering a figure).  Don't do anything!
c
          continue
        else
c
c  Figure is a single number
c
          call addstr(sq//'Figu{'//nofq(1:lnof)//'}{'//ch1q//'}',
     *           10+lnof,soutq,lsout)
        end if
        if (ic .ge. 6) go to 2
        ic = ic+1
        nof = nof+4
        nofa = nofa+4
        go to 1
2     continue
      if (abs(offnsk) .gt. .0001) then
        notexq = sq//'off{'
        if (offnsk .lt. -9.995) then
          write(notexq(6:11),'(f6.2)')offnsk
          lnote = 11
        else if (offnsk.lt.-.995 .or. offnsk.gt.9.995) then
          write(notexq(6:10),'(f5.2)')offnsk
          lnote = 10
        else if (offnsk.lt.-.0001 .or. offnsk.gt..995) then
          write(notexq(6:9),'(f4.2)')offnsk
          lnote = 9
        else
          write(notexq(6:8),'(f3.2)')offnsk
          lnote = 8
        end if
        notexq = notexq(1:lnote)//sq//'noteskip}'
        call addstr(notexq,lnote+10,soutq,lsout)
      end if
      if (ifig .lt. nfigs) then
        ifig = ifig+1
      else
        nfigs=0
        figcheck = .false.
      end if
      return
      end
      subroutine writflot(x,notexq,lenline)
      character*(*) notexq
      if (x .lt. 0.95) then
        write(notexq(lenline+1:lenline+2),'(f2.1)')x
        lenline = lenline+2
      else if (x .lt. 9.95) then
        write(notexq(lenline+1:lenline+3),'(f3.1)')x
        lenline = lenline+3
      else
        write(notexq(lenline+1:lenline+4),'(f4.1)')x
        lenline = lenline+4
      end if
      return
      end
      subroutine readmeter(lineq,iccount,mtrnum,mtrden)
      character*128 lineq
      character*1 durq,chax
      if (index(lineq(iccount+1:iccount+3),'/') .eq. 0) then
c
c  No slashes, so use old method
c
        call getchar(lineq,iccount,durq)
        if (durq .eq. '-') then
c
c  Negative numerator is used only to printed; signals vertical slash
c
          call getchar(lineq,iccount,durq)
          mtrnum = -(ichar(durq)-48)
        else if (durq .eq. 'o') then
c
c  Numerator is EXACTLY 1
c
          mtrnum = 1
        else
          mtrnum = ichar(durq)-48
          if (mtrnum .eq. 1) then
c
c  Numerator is >9
c
            call getchar(lineq,iccount,durq)
            mtrnum = 10+ichar(durq)-48
          end if
        end if
        call getchar(lineq,iccount,durq)
        if (durq .eq. 'o') then
          mtrden = 1
        else
          mtrden = ichar(durq)-48
          if (mtrden .eq. 1) then
            call getchar(lineq,iccount,durq)
            mtrden = 10+ichar(durq)-48
          end if
        end if
      else
c
c  Expect the form m[n1]/[n2]/[n3]/[n4] . Advance iccount by one from '/' or 'm'
c
        iccount = iccount+1
        ns = index(lineq(iccount:128),'/')
        read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrnum
c
c  Reset iccount to start of second integer
c
        iccount = iccount+ns
c
c  There must be either a slash or a blank at pos'n 2 or 3
c
        ns = index(lineq(iccount:iccount+2),'/')
        if (ns .eq. 0) ns = index(lineq(iccount:iccount+2),' ')
        read(lineq(iccount:iccount+ns-2),'(i'//chax(47+ns)//')')mtrden
c
c  Set iccount to last character used
c
        iccount = iccount+ns-1
      end if
      return
      end
      subroutine readnum(lineq,iccount,durq,fnum)
c
c  This reads a number starting at position iccount.  Remember that on exit,
c  getchar leaves iccount at the last character retrieved.  So must only
c  call this routine *after* detecting a number or decimal.
c  On exit, durq is next character after end of number.
c
      character*128 lineq
      character*1 durq,chax
      i1 = iccount
1     call getchar(lineq,iccount,durq)
      if (index('0123456789.',durq) .gt. 0) go to 1
      i2 = iccount-1
      if (i2 .lt. i1) then
        print*,'Found "'//durq//'" instead of number'
        stop 1
      else if (lineq(i1:i1).eq.'.'.and.lineq(i2:i2).eq.'.') then
        i2 = i2-1
        iccount = iccount-1
      end if
      icf = i2-i1+49
      read(lineq(i1:i2),'(f'//chax(icf)//'.0)')fnum
      return
      end
      subroutine dotrill(iv,ip,iornq,noteq,lnoten,notexq,lnote)
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      character*1 chax
      character*8 noteq
      character*79 notexq
      logical tronly,btest
      do 1 itr = 1 , ntrill
        if (iv.eq.ivtrill(itr) .and. ip.eq.iptrill(itr)) go to 2
1     continue
      print*,'Problem in dotrill.  Call Dr. Don'
      stop
2     continue
      tronly = xnsktr(itr) .lt. 0.01
      if (tronly) then
        notexq = chax(92)//'zcharnote'
        lnote = 10
      else if (btest(iornq,7)) then
        notexq = chax(92)//'Trille'
        lnote = 7
      else
        notexq = chax(92)//'trille'
        lnote = 7
      end if
      notexq = notexq(1:lnote)//noteq(1:lnoten)//'{'
      lnote = lnote+lnoten+1
c
c  Write trill duration to nearest tenth of a noteskip
c
      if (tronly) then
        notexq = notexq(1:lnote)//chax(92)//'it tr}'
        lnote = lnote+7
        return
      end if
      if (xnsktr(itr) .lt. .95) then
        nfmt = 2
      else if (xnsktr(itr) .lt. 9.95) then
        nfmt = 3
      else
        nfmt = 4
      end if
      write(notexq(lnote+1:lnote+nfmt),'(f'//chax(48+nfmt)//'.1)')
     *   xnsktr(itr)
      lnote = lnote+nfmt
      notexq = notexq(1:lnote)//'}'
      lnote = lnote+1
      return
      end
      subroutine docrd(ivx,ip,nodu,ncm,iv,tnow,soutq,lsout,ulq,ibmcnt,
     *                 islur,nvmx,nv,beamon,nolevm,ihornb,nornb,stemlen)
      parameter (nm=12,mv=24576)
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
     *                flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
     *                rtshfac
      integer*2 mmidi
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
      logical lowdot
      integer*4 ihornb(nm,24),nornb(nm)
      character*1 ulq(nm,8),chax
      character*7 nosymq
      character*8 noteq
      character*79 notexq,outq
      character*80 soutq
      logical btest,isleft,isright,beamon
      character*79 inameq
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,idsig,
     *   lnam(nm),inameq(nm)
c
c  This subr. once produced notexq for entire chord.  10/18/97 altered to write
c    chord notes as we go.  10/22/97 find range of icrd first.
c    2/25/98 moved rangefinding to precrd so done before slurs, so now
c    on entry, icrd1, icrd2 define range of icrd for this chord.
c
c  Set counter (for this note) for chord notes present.  Set notmain=T.
c    Will test for notmain=.true. in addmidi to tell whether to save pitch.  
c
      nmidcrd = 0
      notmain = .true.
      crdacc = .false.
      do 5 icrd = icrd1 , icrd2
        lnote = 0
	nolev = iand(ishft(icrdat(icrd),-12),127)
c
c  Lower dot for lower-voice notes?.  Conditions are:
c   1. Dotted time value
c   2. Lower voice of two
c   3. Note is on a line
c   4. Not a rest (cannot be a rest in a chord!)
c.  5. Flag (lowdot) is set to true
c
	if (lowdot .and. nvmx.eq.2 .and. ivx.le.nv) then
	  if (2**log2(nodu).ne.nodu .and. mod(nolev-ncm,2).eq.0) then
	    if (btest(icrdat(icrd),26)) then
c
c  Note already in movdot list.  Drop by 2.
c
	       call setbits(icrdot(icrd),7,0,
     *                      igetbits(icrdot(icrd),7,0)-20)
             else
c
c  Not in list so just move it right now
c
	      call dotmov(-2.,0.,soutq,lsout,igetbits(islur,1,3))
	    end if
	  end if
	end if
	if (btest(icrdat(icrd),26)) then
c
c  Move the dot.
c
	  updotc = 0.1*(iand(127,icrdot(icrd))-64)
	  rtdotc = 0.1*(iand(127,ishft(icrdot(icrd),-7))-64)
	  call dotmov(updotc,rtdotc,soutq,lsout,igetbits(islur,1,3))
	end if
	isleft = btest(icrdat(icrd),23)
	isright = btest(icrdat(icrd),24)
c
c  Check for ornament in chord.
c
	if (icrdorn(icrd) .gt. 0) then
	  call putorn(icrdorn(icrd),nolev,nolevm,nodu,nornb,ulq,
     *         ibmcnt,ivx,ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,
     *         ip,0,beamon,.true.)
c
c     subroutin putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx,
c    *     ncm,islur,nvmx,nv,ihornb,stemlen,outq,lout,ip,islhgt,
c    *     notcrd,beamon,iscrd)
c
          call addstr(outq,lout,soutq,lsout)
        end if
c
c  Chord-note symbol.  First check for breve
c
        if (nodu .eq. 128) then
          nosymq = chax(92)//'zbreve'
          lsym = 7
        else
c
c  Not a breve chord.  Get first letters in chord-note symbol
c
          if (isleft) then
            nosymq = chax(92)//'l'
          else if (isright) then
            nosymq = chax(92)//'r'
          else
            nosymq = chax(92)//'z'
          end if
          if (nodu .ge. 64) then
            nosymq = nosymq(1:2)//'w'
          else if (nodu .ge. 32) then
            nosymq = nosymq(1:2)//'h'
          else
            nosymq = nosymq(1:2)//'q'
          end if
          if (2**log2(nodu) .eq. nodu) then
            lsym = 3
          else if (.not.btest(islur,3)) then
c
c  Single dot
c
            nosymq = nosymq(1:3)//'p'
            lsym = 4
          else
c
c  Double dot
c
            nosymq = nosymq(1:3)//'pp'
            lsym = 5
          end if
        end if
        if (btest(icrdat(icrd),19)) then
c
c  Accidental.  Build up bits 0-3 of nacc
c
          nactmp = igetbits(icrdat(icrd),3,20)
c
c  Kluge for bigness.  Only means 'As' has not been issued
c
          if (bacfac .ne. 1.e6) nactmp = nactmp+8
          call doacc(igetbits(icrdot(icrd),7,20)-64,
     *        igetbits(icrdot(icrd),6,14),btest(icrdat(icrd),23),
     *        notexq,lnote,nactmp,nolev,ncmid(iv,ip))
          notexq = notexq(1:lnote)//nosymq
          crdacc = .true.
        else
          notexq = nosymq
        end if
        lnote = lnote+lsym
c
c  Get note name (again if accid, due to possible octave jump)
c
        call notefq(noteq,lnoten,nolev,ncm)
        if (lnoten.eq.1) call addblank(noteq,lnoten)
c
c  Put in note name
c
        notexq = notexq(1:lnote)//noteq
        lnote = lnote+lnoten
        if (btest(icrdat(icrd),25)) then
c
c  Arpeggio signal
c
          call putarp(tnow,iv,nolev,ncm,soutq,lsout)
        end if
        call addstr(notexq,lnote,soutq,lsout)
        if (ismidi) then
c
c  Here is where we collect MIDI pitch info for the chord note.  By checking
c    notmain, addmidi(...) knows to just compute the 
c    pitch number and store it in mcpitch(nmidcrd).  Then on call to addmidi()
c    for MAIN note, will put in note codes for all chord notes + main note.
c   
          kv = 1
          if (ivx .gt. iv) kv=2
          nmidcrd = nmidcrd+1
          call addmidi(midchan(iv,kv),nolev,igetbits(icrdat(icrd),3,20),
     *      isig,1.,.false.,.false.)
        end if
5     continue
      notmain = .false.
      return
      end
      subroutine dograce(ivx,ip,ptgr,soutq,lsout,ncm,nacc,ig,ipl,
     *  farend)
c
c  ip will be one LESS than current note, for way-after's before bar-end,
c    It is only used to find ig.
c  ig is returned to makeabar in case there's a slur that needs to be ended
c
      parameter (nm=12)
      common /comgrace/ ivg(37),ipg(37),nolevg(74),itoff(74),aftshft,
     *                nng(37),ngstrt(37),ibarmbr,mbrest,xb4mbr,
     *                noffseg,ngrace,nvolt,ivlit(52),iplit(52),nlit,
     *                lenlit(52),multg(37),upg(37),slurg(37),slashg(37),
     *                naccg(74),voltxtq(6),litq(52)
      common /spfacs/ grafac,acgfac,accfac,xspfac,xb4fac,clefac,emgfac,
     *                flagfac,dotfac,bacfac,agc1fac,gslfac,arpfac,
     *                rptfac,lrrptfac,dbarfac,ddbarfac,dotsfac,upstmfac,
     *                rtshfac
      common /comask/ bar1syst,fixednew,scaldold,
     *                wheadpt,fbar,poenom
      common /comslur/ listslur,upslur(nm,2),ndxslur
      common /comoct/ noctup
      logical upg,slurg,slashg,bar1syst,upslur,btest,isgaft,iswaft,
     *        normsp,farend
      real*4 ptgr(37)
      character*80 soutq
      character*128 litq
      character*79 notexq
      character*10 voltxtq
      character*8 noteq
      character*3 acsymq
      character*1 sq,chax
      sq = chax(92)
      isgaft = btest(ipl,29)
      iswaft = btest(ipl,31)
      normsp = .not. isgaft
c
c  Find ig.
c
      do 120 ig = 1 , ngrace
        if (ipg(ig).eq.ip .and. ivg(ig).eq.ivx) go to 121
120   continue
      print*,'Problem finding grace index in dograce'
      stop
121   continue
      ngs = ngstrt(ig)
      mg = multg(ig)
c
c  For way-after-graces at end of bar, must set the octave.
c
      if (farend) then
        noctup = 0
        if (ncm .eq.23) noctup = -2
      end if
      if (slurg(ig) .and. .not.iswaft .and..not.isgaft) then
        if (listslur .eq. 4095) then
          print*
          print*,'You defined the thirteenth slur, one too many!'
          write(15,'(/,a)')
     *           'You defined the thirteenth slur, one too many!'
          stop 1
        end if
c
c  Slur on fore-grace.  Get index of next slur not in use, from 11 down.
c
        ndxslur = log2(4095-listslur)
      end if
      if (nng(ig) .eq. 1) then
c
c  Single grace.
c
        if (normsp) then
c
c  Anything but GA
c
          call addstr(sq//'shlft',6,soutq,lsout)
          niptgr = nint(ptgr(ig))
          if (niptgr .lt. 10) then
            call addstr(chax(48+niptgr)//'{',2,soutq,lsout)
          else if (niptgr .lt. 100) then
            write(notexq(1:2),'(i2)')niptgr
            call addstr('{'//notexq(1:2)//'}{',5,soutq,lsout)
          else
            print*,
     *  'Call Dr. Don if you really want grace note group > 99 pt'
            stop
          end if
        else
          call addstr(sq//'gaft{1.5}{',11,soutq,lsout)
c
c  GA.  Compute aftshft, for later use.
c
          aftshft = grafac
          if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+agc1fac
          aftshft = aftshft*wheadpt
        end if
        if (slurg(ig) .and. .not.isgaft .and..not.iswaft) then
c
c  Start slur on pre-grace.  No accounting needed since will be ended very soon.
c
          call notefq(noteq,lnoten,nolevg(ngs),ncm)
          if (upg(ig)) then
            call addstr(sq//'islurd',7,soutq,lsout)
          else
            call addstr(sq//'isluru',7,soutq,lsout)
          end if
          if (ndxslur .lt. 10) then
            call addstr(chax(48+ndxslur)//noteq(1:lnoten),1+lnoten,
     *                 soutq,lsout)
          else
            call addstr('{1'//chax(38+ndxslur)//'}'//noteq(1:lnoten),
     *            4+lnoten,soutq,lsout)
          end if
        end if
        if (naccg(ngs) .gt. 0) then
          call notefq(noteq,lnoten,nolevg(ngs),ncm)
          if (lnoten .eq. 1) call addblank(noteq,lnoten)
          call accsym(naccg(ngs),acsymq,lacc)
          call addstr(sq//'big'//acsymq(1:lacc)//
     *         noteq(1:lnoten),4+lacc+lnoten,soutq,lsout)
        end if
        if (slashg(ig)) then
          notexq = sq//'grc'
          lnote = 4
        else if (mg .eq. 0) then
          notexq = sq//'zq'
          lnote = 3
        else
          notexq = sq//'zc'
          do 61 i = 2 , mg
            notexq = notexq(1:i+1)//'c'
61        continue
          lnote = mg+2
        end if
        if (upg(ig)) then
          notexq = notexq(1:lnote)//'u'
        else
          notexq = notexq(1:lnote)//'l'
        end if
        call addstr(notexq,lnote+1,soutq,lsout)
        call notefq(noteq,lnoten,nolevg(ngs),ncm)
        if (lnoten .eq. 1) call addblank(noteq,lnoten)
        call addstr(noteq,lnoten,soutq,lsout)
        if (slashg(ig)) call addstr(sq//'off{-'//sq//
     *      'noteskip}',16,soutq,lsout)
c
c  Above code needed since slashg causes spacing
c
        if (slurg(ig) .and. (iswaft.or.isgaft)) then
c
c  Terminate slur on single after-grace
c
          ndxslur = igetbits(ipl,4,23)
          call notefq(noteq,lnoten,nolevg(ngs),ncm)
          call addstr(sq//'tslur',6,soutq,lsout)
          if (ndxslur .lt. 10) then
            call addstr(chax(48+ndxslur)//noteq(1:lnoten),
     *              1+lnoten,soutq,lsout)
          else
            call addstr('{1'//chax(38+ndxslur)//'}'//noteq(1:lnoten),
     *              4+lnoten,soutq,lsout)
          end if
          slurg(ig) = .false.
          listslur = ibclr(listslur,ndxslur)
        end if
        call addstr('}',1,soutq,lsout)
      else
c
c  Multiple grace.  Put in literally.  Compute beam stuff
c
        sumx = 0.
        sumy = 0.
        sumxy = 0.
        sumxx = 0.
        sumyy = 0.
        x = 0.
        do 118 ing = ngs , ngs+nng(ig)-1
          if (ing.gt.ngs .and. naccg(ing).gt.0) x = x+acgfac
          y = nolevg(ing)
          sumx = sumx + x
          sumy = sumy + y
          sumxy = sumxy + x*y
          sumxx = sumxx + x*x
          sumyy = sumyy + y*y
          x = x+emgfac
118     continue
        delta = nng(ig)*sumxx-sumx*sumx
        em = (nng(ig)*sumxy-sumx*sumy)/delta
        islope = nint(0.5*em*gslfac)
        if (iabs(islope) .gt. 9) islope = isign(9,islope)
        beta = (sumy-islope/gslfac*sumx)/nng(ig)
        nolev1 = nint(beta)
c
c  Back up
c
        notexq = sq//'tinynotesize'//sq//'off{'
        if (normsp) then
          write(notexq(19:23),'(a1,f4.1)')'-',ptgr(ig)
          call addstr(notexq(1:23)//'pt}',26,soutq,lsout)
        else
          aftshft = wheadpt*1.33
          if (naccg(ngstrt(ig)).gt.0) aftshft = aftshft+wheadpt*0.5
          write(notexq(19:22),'(f4.1)')aftshft
          call addstr(notexq(1:22)//'pt}'//sq//'bsk',29,soutq,lsout)
        end if
c
c  Start the beam
c
        notexq = sq//'ib'
        do 119 ing = 2 , mg
           notexq = notexq(1:ing+1)//'b'
119     continue
        if (upg(ig)) then
          notexq = notexq(1:mg+2)//'u'
        else
          notexq = notexq(1:mg+2)//'l'
        end if
        notexq = notexq(1:mg+3)//'0'
c
c  Get starting note for beam
c
        call notefq(noteq,lnoten,nolev1,ncm)
        call addstr(notexq(1:mg+4)//noteq(1:lnoten),
     *    mg+4+lnoten,soutq,lsout)
c
c  Put in the slope
c
        if (islope .ge. 0) then
          call addstr(chax(48+islope),1,soutq,lsout)
        else
          call addstr('{-'//chax(48-islope)//'}',4,soutq,lsout)
        end if
c
c  Start a slur on fore-grace
c
        if (slurg(ig) .and. .not.isgaft .and. .not.iswaft) then
          call notefq(noteq,lnoten,nolevg(ngs),ncm)
          if (upg(ig)) then
            call addstr(sq//'islurd',7,soutq,lsout)
          else
            call addstr(sq//'isluru',7,soutq,lsout)
          end if
          if (ndxslur .lt. 10) then
            call addstr(chax(48+ndxslur)//noteq(1:lnoten),1+lnoten,
     *                 soutq,lsout)
          else
            call addstr('{1'//chax(38+ndxslur)//'}'//noteq(1:lnoten),
     *                  4+lnoten,soutq,lsout)
          end if
        end if
c
c  Put in first note.  Call notefq again in case octave changed
c
        call notefq(noteq,lnoten,nolevg(ngs),ncm)
        if (naccg(ngs) .eq. 0) then
          notexq = sq//'zqb0'//noteq(1:lnoten)
          lnote = 5+lnoten
        else
          if (lnoten .eq. 1) call addblank(noteq,lnoten)
          call accsym(naccg(ngs),acsymq,lacc)
          notexq = sq//'big'//acsymq(1:lacc)//noteq(1:lnoten)
          lnote = 4+lacc+lnoten
          call notefq(noteq,lnoten,nolevg(ngs),ncm)
          notexq =notexq(1:lnote)//sq//'zqb0'//noteq(1:lnoten)
          lnote = lnote+5+lnoten
        end if
        call addstr(notexq,lnote,soutq,lsout)
        do 127 ing = ngs+1 , ngs+nng(ig)-1
c
c  Skip
c
          ptoff = wheadpt*emgfac
          if (naccg(ing).gt.0) ptoff = ptoff+wheadpt*acgfac
          if (isgaft .and. .not.iswaft) aftshft = aftshft+ptoff
          notexq = sq//'off{'
          write(notexq(6:8),'(f3.1)')ptoff
          call addstr(notexq(1:8)//'pt}',11,soutq,lsout)
          if (ing .eq. ngs+nng(ig)-1) then
c
c  Terminate beam if needed
c
            if (upg(ig)) then
              call addstr(sq//'tbu0',5,soutq,lsout)
            else
              call addstr(sq//'tbl0',5,soutq,lsout)
            end if
c
c  Terminate after slur if needed
c
            if ((isgaft.or.iswaft) .and. slurg(ig)) then
              if (iswaft) ndxslur = igetbits(ipl,4,23)
              call notefq(noteq,lnoten,nolevg(ing),ncm)
              call addstr(sq//'tslur',6,soutq,lsout)
              if (ndxslur .lt. 10) then
                call addstr(chax(48+ndxslur)//noteq(1:lnoten),
     *              1+lnoten,soutq,lsout)
              else
                call addstr('{1'//chax(38+ndxslur)//'}'
     *                      //noteq(1:lnoten),4+lnoten,soutq,lsout)
              end if
c
c  Stop slur terminator after exit from this subroutine
c
              listslur = ibclr(listslur,ndxslur)
              slurg(ig) = .false.
            end if
          end if
c
c  Accidental if needed
c
          if (naccg(ing).gt.0) then
            call notefq(noteq,lnoten,nolevg(ing),ncm)
            if (lnoten .eq. 1) call addblank(noteq,lnoten)
            call accsym(naccg(ing),acsymq,lacc)
            call addstr(sq//'big'//acsymq(1:lacc)
     *                  //noteq(1:lnoten),4+lacc+lnoten,soutq,lsout)
          end if
c
c  Put in the (beamed) grace note
c
          call notefq(noteq,lnoten,nolevg(ing),ncm)
          call addstr(sq//'zqb0'//noteq(1:lnoten),5+lnoten,
     *                soutq,lsout)
127     continue
c
c  Terminate the grace
c
        notexq = sq//'normalnotesize'//sq//'off{'
        lnote = 20
        ptoff = wheadpt*emgfac
        if (iand(nacc,3) .gt. 0) ptoff = ptoff+wheadpt*accfac
        if (isgaft .and. .not.iswaft) then
          notexq = notexq(1:20)//'-'
          lnote = 21
          ptoff = aftshft
        end if
        if (ptoff .lt. 9.95) then
          write(notexq(lnote+1:lnote+3),'(f3.1)')ptoff
          lnote = lnote+3
        else
          write(notexq(lnote+1:lnote+4),'(f4.1)')ptoff
          lnote = lnote+4
        end if
        call addstr(notexq(1:lnote)//'pt}',lnote+3,soutq,lsout)
        if (isgaft.and..not.iswaft) call addstr(sq//'sk',3,soutq,lsout)
      end if
      return
      end
      subroutine wsclef(iv,ninow,clefq,nclef)
c
c  Writes \setclef for instrument containing voice iv
c
      parameter (nm=12)
      common /comlast/ islast
      logical islast
      common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
      logical rename
      character*1 clefq(nm),chax
      character*20 temq
      if (nclef .lt. 7) then
        clefq(iv) = chax(48+nclef)
      else
        clefq(iv)='9'
      end if
      if (.not.islast) return
      iv1 = 1
      do 1 iinst = 1 , ninow
        if (iv .lt. iv1+nspern(iinst)) go to 2
        iv1 = iv1+nspern(iinst)
1     continue
      print*
      print*,'Should not be here in wsclef!'
      stop 1
2     continue
      iv2 = iv1+nspern(iinst)-1
      if (iinst .lt. 10) then
        temq = chax(92)//'setclef'//chax(48+iinst)
        ltem = 9
      else
        write(temq,'(a9,i2,a1)') chax(92)//'setclef{',iinst,'}'
        ltem = 12
      end if
      if (iv1 .eq. iv2) then
        write(11,'(a)')temq(1:ltem)//clefq(iv)//'%'
      else
        temq = temq(1:ltem)//'{'
        ltem = ltem+1
        do 3 iiv = iv1 , iv2
          temq = temq(1:ltem)//chax(48+numclef(clefq(iiv)))
          ltem = ltem+1
3       continue
        write(11,'(a)')temq(1:ltem)//'}%'
      end if
      return
      end
      subroutine endslur(stemup,upslur,nolev,iupdn,ndxslur,ivoff,ncm,
     *  soutq,lsout)
      logical shift,stemup,upslur
      character*80 soutq
      character*79 notexq
      character*8 noteq
      character*1 chax
      shift = .not.stemup .and. .not.upslur
      if (.not.shift) then
c
c  No shift needed
c
         notexq = chax(92)//'tslur'
         lnote = 6
      else
c
c  Shift needed
c
         notexq = chax(92)//'ts'
         lnote = 3
      end if
c      notexq = notexq(1:lnote)//chax(48+ndxslur)
c      lnote = lnote+1
      if (ndxslur .lt. 10) then
        notexq = notexq(1:lnote)//chax(48+ndxslur)
        lnote = lnote+1
      else
        notexq = notexq(1:lnote)//'{1'//chax(38+ndxslur)//'}'
        lnote = lnote+4
      end if
      call notefq(noteq,lnoten,nolev+iupdn+ivoff,ncm)
      notexq = notexq(1:lnote)//noteq(1:lnoten)
      lnote = lnote+lnoten
      if (shift) then
        notexq = notexq(1:lnote)//'{-.6}'
        lnote = lnote+5
      end if
      call addstr(notexq,lnote,soutq,lsout)
      return
      end
      subroutine getfig(itoff,charq,lineq,iccount,isfig,itfig,
     *   itsofar,nodur,figq,ivx,nfigs)
      logical isfig
      character*1 charq
      character*6 figq
      character*128 lineq
      if (ivx .ne. 1) then
c
c  Read past the figure
c
6       call getchar(lineq,iccount,charq)
        if (charq .ne. ' ') go to 6
        return
      end if
      nfigs = nfigs+1
      itoff = 0
      if (charq .eq. 'x') then
c
c  Floating figure.
c
        call getchar(lineq,iccount,charq)
        read(charq,'(i1)')noff
        call getchar(lineq,iccount,charq)
        read(charq,'(i1)')loff
        itoff = noff*ifnodur(loff,'x')
        call getchar(lineq,iccount,charq)
      else
c
c  Figure on a note
c
        isfig = .true.
      end if
      itfig = itsofar+itoff-nodur
      lfig = 1
      figq = charq
5     call getchar(lineq,iccount,charq)
      if (charq .ne. ' ') then
        figq = figq(1:lfig)//charq
        lfig = lfig+1
        go to 5
      end if
      return
      end
      subroutine eskb4(ip,ivx,in,ib,space,tstart,fbar,itrpt,esk)
c
c  Get elemskips to previous note.  Called only for graces, no xtups involved.
c
      parameter (nm=12)
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      character*1 ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,isfig
      real*4 tstart(80),space(80)
      common /comtol/ tol
      itnd = nint(to(in))
      if (ip.eq.1 .or. itnd.eq.itrpt) then
c
c  Start of bar or after rpt.
c
        esk = fbar
        return
      else
        esk = 0.
        itprev = itnd-nodur(ivx,ip-1)
        do 1 iib = ib , 1 , -1
          if (tstart(iib) .lt. itprev+tol) then
c
c  This is the block
c
            nnsk = nint(float((itnd-itprev))/space(iib))
            esk = esk+nnsk*feon(space(iib))
            return
          else
            nnsk = nint((itnd-tstart(iib))/space(iib))
            esk = esk+nnsk*feon(space(iib))
            itnd = nint(tstart(iib))
          end if
1       continue
      end if
      print*,'Problem in eskb4.  Send files to Dr. Don'
      stop
      end
      subroutine putorn(iornq,nolev,nolevm,nodur,nornb,ulq,ibmcnt,ivx,
     *     ncm,islur,nvmx,nv,ihornb,stemlin,outq,lout,ip,islhgt,
     *     beamon,iscrd)
c
c  All args are individual array element *values* except nornb,ihornb,ulq.
c  notcrd = .true. if ornament is on main note.
c    nolevm is level of main note (for chords)
c
      parameter (nm=12)
      character*1 ulpzq,ulq(nm,8),udqq,sq,chax
      character*8 noteq
      character*79 notexq,outq
      integer*4 ihornb(nm,24),nornb(nm)
      logical btest,iscrd,usehornb,beamon
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      sq = chax(92)
      lout = 0
      usehornb = .false.
      if (nodur .lt. 64) then
        stemlen = stemlin
      else
        stemlen = 0.
      end if
c
c  Get up-downness. ulpzq is opposite from stem direction for both beams and
c    non beams.  Can use in name of ornament [ . or _ ]
c
      if (beamon) then
        if (ulq(ivx,ibmcnt) .eq. 'u') then
          ulpzq = 'l'
        else
          ulpzq = 'u'
        end if
      else
        if (udqq(nolevm,ncm,islur,nvmx,ivx,nv).eq.'l' ) then
          ulpzq = 'u'
        else
          ulpzq = 'l'
        end if
      end if
c
c  To enable >1 ornament on a note, next line is top of manual loop.
c
2     continue
c
c  Bit # of last ornament (last of bits 0-21)
c
      ibit = log2(iand(iornq,4194303))
      iornt = 2**ibit
c
c  Begin routine to set height.  Bits 0-13: (stmgx+Tupf._)
c  14: Down fermata, was F  15: Trill w/o "tr", was U, 16-18: edit. s,f,n
c  19-20: >^, 21: ? (with or w/o 16-18)
c
c  Do not use beam height for . or _
c
      if (btest(iornq,22) .and. iand(iornt,6144).eq.0) then
c
c  Height is set by special beam stuff.  
cc  Following block leaves ihorn set for later orns on same note.
c  No! Do not leave ihorn set, do separately for every ornament
c
c        if (.not.usebmht) then
        ihorn = ihornb(ivx,nornb(ivx))
c          if (iand(iornt,6144).gt.0) then
cc
cc  Fine-tune for _ or .  Note flaw: for later normal orn here, ht. is wrong.
cc
c            ihorn = ihorn+1-2*index('l',ulpzq)
c            ulpzq = chax(225-ichar(ulpzq))
c          else if (ulpzq .eq. 'u') then
c          else if (ulpzq .eq. 'u') then
c            ihorn = ihorn-2
c          end if
        if (ulpzq .eq. 'u') ihorn = ihorn-2
c        nornb(ivx) = nornb(ivx)+1
c
c  Following flag tells whether to increment nornb when exiting the subroutine.
c
        usehornb = .true.
c        end if
      else if (ibit .eq. 14) then
c
c  Down fermata.  Don't worry about upper chord notes.
c
        if (ulpzq .eq. 'l') then
          ihorn = min(nolev,ncm-3)
        else
          ihorn = min(nolev-stemlen,ncm-3.)
        end if
      else if (btest(iornt,13) .or. btest(iornt,0)) then
c
c  ( or )
c
        ihorn = nolev
      else if (iand(iornt,6144) .gt. 0) then
c
cc  Staccato . or tenuto _ , but not special beam stuff.  Need up-down info
c  NOTE: removed .&_ from special beam treatment.
c  Staccato . or tenuto _  Need up-down info
c
        if (.not.iscrd .or. (maxlev.ne.nolev.and.ulpzq.eq.'l') .or.
     *                      (minlev.ne.nolev.and.ulpzq.eq.'u')) then
          ihorn = nolev
        else if (maxlev .eq. nolev) then
          ulpzq = 'u'
          ihorn = max(nolev+stemlen,ncm+3.)
        else
          ulpzq = 'l'
          ihorn = min(nolev-stemlen,ncm-3.)
        end if
      else if (iscrd .and. nolev .eq. minlev) then
        if (ulpzq .eq. 'l') then
          ihorn = min(nolev-3,ncm-6)
        else
          ihorn = min(nolev-nint(stemlen)-3,ncm-6)
        end if
      else if (ulpzq.eq.'l') then
c
c  (iscrd and nolev=maxlev) or (.not.iscrd)
c
        ihorn = max(nolev+stemlen+2,ncm+5.)
      else
        ihorn = max(nolev+2,ncm+5)
      end if
      ioff = 0
c
c  Begin routine to set name.  Bits 0-13: (stmgx+Tupf._)
c  14: Down fermata, was F  15: Trill w/o "tr", was U, 16-18: edit. s,f,n
c
      if (btest(iornt,2)) then
        notexq = sq//'shake'
        lnote = 6
      else if (btest(iornt,3)) then
        notexq = sq//'mordent'
        lnote = 8
      else if (btest(iornt,1)) then
        notexq = sq//'mtr'
        lnote = 4
      else if (btest(iornt,5)) then
        notexq = sq//'xtr'
        lnote = 4
      else if (btest(iornt,6)) then
        notexq = sq//'ptr'
        lnote = 4
      else if (btest(iornt,13)) then
        notexq = sq//'rpn'
        lnote = 4
      else if (btest(iornt,0)) then
        notexq = sq//'lpn'
        lnote = 4
      else if (btest(iornt,12)) then
        notexq = sq//ulpzq//'st'
        lnote = 4
      else if (btest(iornt,11)) then
        notexq = sq//ulpzq//'pz'
        lnote = 4
      else if (btest(iornt,8)) then
        notexq = sq//'upz'
        lnote = 4
        ioff = -2
      else if (btest(iornt,9)) then
        notexq = sq//'uppz'
        lnote = 5
        ioff = -2
      else if (btest(iornt,10)) then
        if (nodur .lt. 48) then
          notexq = sq//'fermataup'
        else
          notexq = sq//'Fermataup'
        end if
        lnote = 10
        ioff = -2
      else if (btest(iornt,14)) then
        if (nodur .lt. 48) then
          notexq = sq//'fermatadown'
        else
          notexq = sq//'Fermatadown'
        end if
        lnote = 12
      else if (btest(iornt,21)) then
c
c  "?" in editorial ornament.  Clear bit 16-18 after use, since ibit=21
c
        if (btest(iornq,16)) then
          notexq = sq//'qsharp'
          lnote = 7
          ioff = 2
          iornq = ibclr(iornq,16)
        else if (btest(iornq,17)) then
          notexq = sq//'qflat'
          lnote = 6
          ioff = 1
          iornq = ibclr(iornq,17)
        else if (btest(iornq,18)) then
          notexq = sq//'qnat'
          lnote = 5
          ioff = 2
          iornq = ibclr(iornq,18)
        else
          notexq = sq//'qedit'
          lnote = 6
          ioff = 0
        end if
      else if (btest(iornt,16)) then
        notexq = sq//'esharp'
        lnote = 7
        ioff = 2
      else if (btest(iornt,17)) then
        notexq = sq//'eflat'
        lnote = 6
        ioff = 1
      else if (btest(iornt,18)) then
        notexq = sq//'enat'
        lnote = 5
        ioff = 2
      else if (btest(iornt,19)) then
        notexq = sq//'usf'
        lnote = 4
        ioff = -2
      else if (btest(iornt,20)) then
        notexq = sq//'usfz'
        lnote = 5
        ioff = -2
      end if
c
c  User-defined level shift of ornament from default?
c
      if (btest(iornq,25)) then
c
c  Find which (if any) element of kudorn has the shift.
c
        do 3 iudorn = 1 , nudorn
          if (ip+ishft(ivx,8)+ishft(nolev,12)+ishft(ibit,19) .eq.
     *         iand(33554431,kudorn(iudorn))) go to 4
3       continue
c
c  Nothing shifted on this note; exit this loop
c
        go to 5
4       continue
        ioffinc = iand(63,ishft(kudorn(iudorn),-25))-32
        if (ibit.eq.19 .and. ioffinc .lt. -7) then
c
c  Convert usf to lsf.  The reason has to do with positioning being impossile
c  for some mysterious reason when you drop \usf below the staff
c
          notexq = sq//'lsf'
          ioffinc = ioffinc+6
        end if
        ioff = ioff+ioffinc
      end if
5     continue
c
c  Shift level to avoid slur.  Conditions are
c   1.  There is a slur
c   2.  No user-defined orn height shift (btest(iornq,25))
c   3.  upslur (islhgt>0)
c   4.  ornament is not segno(4), ._)(11-13), down ferm(14) or "(" (0) Bin=30737
c   5.  islhgt+3 >=  height already computed.
c
      if (.not.btest(iornq,25) .and.
     *                islhgt.gt.0 .and. iand(iornt,30737).eq.0)
     *  ioff = ioff+dim(islhgt+3,ihorn     )
      call notefq(noteq,lnoten,ihorn+ioff,ncm)
      if (lnoten.eq.1) call addblank(noteq,lnoten)
      if (iand(iornt,32896) .gt. 0) then
c
c  T-trill or trill w/o "tr"
c
        call dotrill(ivx,ip,iornt,noteq,lnoten,notexq,lnote)
      else
        notexq = notexq(1:lnote)//noteq(1:lnoten)
        lnote = lnote+lnoten
      end if
c
c  Zero out the bit for ornament just dealt with.
c
      iornq = ibclr(iornq,ibit)
      if (lout .eq. 0) then
        outq = notexq(1:lnote)
      else
        outq = outq(1:lout)//notexq(1:lnote)
      end if
      lout = lout+lnote
c
c  Check bits 0-21, go back if any are still set
c
      if (iand(iornq,4194303) .gt. 0) go to 2
      if (usehornb) nornb(ivx) = nornb(ivx)+1
      return
      end
      subroutine putxtn(ntupv,iflop,multb,iud,wheadpt,poenom,
     *  nolev1,islope,slfac,xnlmid,islur,lnote,notexq,ncmid,nlnum,
     *  eloff,iup,irest)
c
c  Places digit for xtuplet.
c
      character*1 chax
      character*8 noteq
      character*79 notexq
      logical btest
      if (iflop.ne.0 .and. multb.gt.0) then
c
c Number goes on beam side, move R/L by .5 wheadpt for upper/lower
c
        eloff = eloff-0.5*iud*wheadpt/poenom
c
c  Number goes on beam side, must use beam parameters to set pos'n
c
        nlnum = nolev1+islope/slfac*eloff+iup*(multb+8)
        if (multb .ge. 2) nlnum = nlnum+iup
      else
        nlnum = nint(xnlmid-1+3*iud+iflop*11)
      end if
      if (.not.btest(islur,31)) then
c
c  Only print number when wanted.  First check vert, horiz offset
c
        if (btest(irest,1)) nlnum = nlnum+iand(31,ishft(irest,-2))-16
        if (btest(irest,7)) eloff = eloff+
     *          (.1*iand(31,ishft(irest,-9))-1.6)*wheadpt/poenom
        notexq = chax(92)//'xnum{'
        lnote = 10
        if (eloff .lt. 0.995) then
          write(notexq(7:10),'(i1,f3.2)')0,eloff
        else if (eloff .lt. 9.995) then
          write(notexq(7:10),'(f4.2)')eloff
        else
          write(notexq(7:11),'(f5.2)')eloff
          lnote = 11
        end if
        call notefq(noteq,lnoten,nlnum,ncmid)
        notexq = notexq(1:lnote)//'}'//noteq(1:lnoten)
        lnote = lnote+1+lnoten
        if (ntupv .lt. 10) then
          write(notexq(lnote+1:lnote+1),'(i1)')ntupv
          lnote = lnote+1
        else
          notexq = notexq(1:lnote)//'{'
          write(notexq(lnote+2:lnote+3),'(i2)')ntupv
          notexq = notexq(1:lnote+3)//'}'
          lnote = lnote+4
        end if
      end if
      return
      end
      subroutine mrec1(lineq,iccount,ndxm)
c
c  This is called when (a) macro recording is just starting and
c  (b) at the start of a new line, if recording is on
c
      character*128 lineq,lnholdq
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      logical mrecord,mplay,endmac
      common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
     *                 ic1mac(20),ilmac,iplmac
      character*65536 bufq
      integer*2 lbuf(2000)
      common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
      if (.not.mrecord) then
c
c  Starting the macro
c
        ip1mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount
        il1mac(macnum) = ilbuf-1
        ic1mac(macnum) = iccount
        mrecord = .true.
      end if
      if (iccount .lt. 128) then
        ndxm = index(lineq(iccount+1:128),'M')
        if (ndxm .gt. 0) ndxm = ntindex(lineq(iccount+1:128),'M',
     *                                  128-iccount)
        if (ndxm .gt. 0) then
c
c  This line ends the macro.
c
          ip2mac(macnum) = ipbuf-lbuf(ilbuf-1)+iccount+ndxm
          il2mac(macnum) = ilbuf-1
          mrecord = .false.
        end if
      end if
      return
      end
      subroutine read10(string,lastchar)
      character*65536 bufq
      integer*2 lbuf(2000)
      common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
      character*(*) string
      character*128 lnholdq
      logical lastchar
      common /commac/ macnum,mrecord,mplay,macuse,icchold,lnholdq,endmac
      logical mrecord,mplay,endmac
      common /c1ommac/ ip1mac(20),il1mac(20),ip2mac(20),il2mac(20),
     *                 ic1mac(20),ilmac,iplmac
      if (.not.mplay) then
        if (ilbuf .gt. nlbuf) go to 999
        call getbuf(string)
        return
999     lastchar = .true.
        return
      else
c
c  Play a macro.  Set pointer to first character needed in buffer
c
        if (ilmac .eq. il1mac(macnum)) then
c
c  Getting first line of macro
c
          ip1 = ip1mac(macnum)
          iplmac = ip1-ic1mac(macnum) 
        else if (ilmac .le. il2mac(macnum)) then
c
c  Beyond first line of macro.  Advance line-start pointer.
c
          iplmac = iplmac+lbuf(ilmac-1)
          ip1 = iplmac+1
        else
c
c  Beyond last line of macro.  Terminate it!
c
          mplay = .false.
          endmac = .true.
          return
        end if
        if (ilmac .eq. il2mac(macnum)) then
c
c  Getting last line of macro.
c
          ip2 = ip2mac(macnum)
        else 
c
c  Getting line before last line of macro.
c
          ip2 = iplmac+lbuf(ilmac)
        end if
        if (ip2 .ge. ip1) then
          string = bufq(ip1:ip2)
        else
c
c  Kluge for when macro start is on a line by itself
c
          string = ' '
        end if
        ilmac = ilmac+1
        return
      end if
      end
      subroutine getset(nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,
     *    xmtrnum0,npages,nsyst,musicsize,fracindent,istype0,
     *    inameq,clefq,sepsymq,pathnameq,lpath,isig0)
      parameter (nm=12)
      common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
      character*1 clefq(nm),sepsymq(nm)
      character*40 pathnameq
      character*79 inameq(nm)
      character*128 lineq
      logical istype0,newway,rename
c
c  Get the first line
c
      iccount = 0
9     call getbuf(lineq)
      if (lineq(1:1) .eq. '%') go to 9
      istype0 = lineq(1:3).eq.'---'
      if (istype0) then
c
c  Have TeX input until next line that starts with '---'.  Save in scratch.
c
        open(17,status='SCRATCH')
3       call getbuf(lineq)
        if (lineq(1:3) .ne. '---') then
          write(17,'(a)')lineq
          go to 3
        end if
c
c  Force a new line read on first call to readin
c
        iccount = 128
      end if
c
c  Here, lineq is first line w/ numerical setup data.
c
      nv = nint(readin(lineq,iccount,nline))
      noinst = nint(readin(lineq,iccount,nline))
      newway = noinst.le.0
      if (newway) noinst = -noinst
      do 2 iinst = 1 , noinst
c
c  Seve # of staves per inst in case later drop some inst's.
c
        if (newway) then
c
c  Read in nvi for each instrument
c
          nsperi(iinst) = nint(readin(lineq,iccount,nline))
        else if (iinst .gt. 1 ) then
          nsperi(iinst) = 1
        else
          nsperi(iinst) = nv-noinst+1
        end if
        iiorig(iinst) = iinst
        nspern(iinst) = nsperi(iinst)
2     continue
      mtrnuml = nint(readin(lineq,iccount,nline))
      mtrdenl = nint(readin(lineq,iccount,nline))
cc
cc  Kluge to make mtrdenl work
cc
c      if (mtrdenl .eq. 1) then
c        mtrdenl = 2
c        mtrnuml = mtrnuml*2
c      end if
      mtrnmp = nint(readin(lineq,iccount,nline))
      mtrdnp = nint(readin(lineq,iccount,nline))
      xmtrnum0 = readin(lineq,iccount,nline)
c
c  Original key sig (before any trnasposition) in next position.  Transposed
c  sig for topfile was transferred thru pmxtex.dat.  Need isig0 for key
c  changes if transposed.
c
      isig0 = nint(readin(lineq,iccount,nline))
      npages = nint(readin(lineq,iccount,nline))
      nsyst = nint(readin(lineq,iccount,nline))
      musicsize = nint(readin(lineq,iccount,nline))
      fracindent = readin(lineq,iccount,nline)
c
c  Next noinst non-comment lines are names of instruments.
c
      do 4 i = 1 , noinst
5       call getbuf(inameq(i))
        if (inameq(i)(1:1) .eq. '%') go to 5
4     continue
c
c  Mext non-comment line has nv clef names
c
6     call getbuf(lineq)
      if (lineq(1:1) .eq. '%') go to 6
      iv = 0
      nvsofar = 0
      do 1 jinst = 1 , noinst
        nvsofar = nvsofar+nsperi(jinst)
        do 10 ivi = 1 , nsperi(jinst)
          iv = iv+1
          clefq(iv) = lineq(iv:iv)
          if (iv .eq. nvsofar) then
            sepsymq(iv) = '&'
          else
            sepsymq(iv) = '|'
          end if
10      continue
1     continue
c
c  Mext non-comment line has path name
c
8     call getbuf(pathnameq)
      if (pathnameq(1:1) .eq. '%') go to 8
      lpath = index(pathnameq,' ')-1
      return
      end
      function readin(lineq,iccount,nline)
c
c  Reads a piece of setup data from file lineq, gets a new lineq from
c  file 10 (jobname.pmx) and increments nline if needed,  passes over
c  comment lines
c
      character*128 lineq
      character*1 durq,chax
4     if (iccount .eq. 128) then
1       call getbuf(lineq)
        nline = nline+1
        if (lineq(1:1) .eq. '%') go to 1
        iccount = 0
      end if
      iccount = iccount+1
c
c  Find next non-blank or end of line
c
      do 2 iccount = iccount , 127
        if (lineq(iccount:iccount) .ne. ' ') go to 3
2     continue
c
c  If here, need to get a new line
c
      iccount = 128
      go to 4
3     continue
c
c  iccount now points to start of number to read
c
      i1 = iccount
5     call getchar(lineq,iccount,durq)
c
c  Remember that getchar increments iccount, then reads a character.
c
      if (index('0123456789.-',durq) .gt. 0) go to 5
      i2 = iccount-1
      if (i2 .lt. i1) then
        print*,'Found "'//durq//'" instead of number'
        stop 1
      end if
      icf = i2-i1+49
      read(lineq(i1:i2),'(f'//chax(icf)//'.0)')readin
      return
      end
      subroutine moveln(iuin,iuout,done)
      logical done
      character*129 outq
      done = .false.
      read(iuin,'(a)',end=1) outq
      lenout = llen(outq,129)
      write(iuout,'(a)') outq(1:lenout)
      return
1     done = .true.
      return
      end
      subroutine putarp(tnow,iv,nolev,ncm,soutq,lsout)
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      common /comtol/ tol
      logical lowdot
      character*80 soutq
      character*79 notexq
      character*8 symq(2)
      character*1 chax
      data symq /'raisearp','arpeggio'/

c
c  Find which iarp, if any
c
      do 1 iarp = 1 , narp
        if (abs(tnow-itar(iarp)).lt.tol) go to 2
1     continue
c
c  If here, this is the *first* call for this arp.
c
      narp = narp+1
      itar(narp) = tnow+tol
      ivar1(narp) = iv
      levar1(narp) = nolev
      ncmar1(narp) = ncm
      return
2     continue
c
c  If here, this is second call at this time, iarp points to values from 1st.
c
      if (iv .eq. ivar1(iarp)) then
c
c  Arp is in a single staff.
c
        levbot = min(levar1(iarp),nolev)-ncm+3
        invert = abs(levar1(iarp)-nolev)+1
      else
c
c  Arp covers >1 staff.  Lower staff has to be the first, upper is current and
c  is where the symbol will be written.
c
c        levbot = -ni(2*xinsnow)+3+levar1(iarp)-ncmar1(iarp)
        levbot = -nint(2*xinsnow)+3+levar1(iarp)-ncmar1(iarp)
        invert = -levbot+4+nolev-ncm
      print*,'xinsnow,levar1,ncmar1,levbot,nolev,ncm:'
      write(*,'(f5.1,5i5)')xinsnow,levar1(iarp),ncmar1(iarp),
     *levbot,nolev,ncm
      end if
c
c  isym will be (1,2) if invert is (even,odd).  If even, raise .5\internote
c
      isym = mod(invert,2)+1
      ilvert = (invert+1)/2
      if (levbot .ge. 0 .and. levbot .le. 9) then
c
c  Single digit
c
        notexq = chax(92)//symq(isym)//chax(48+levbot)
        lnote = 10
      else
        notexq = chax(92)//symq(isym)//'{'
        if (levbot .ge. -9) then
c
c  Need two spaces for number
c
          write(notexq(11:13),'(i2,a1)')levbot,'}'
          lnote = 13
        else
          write(notexq(11:14),'(i3,a1)')levbot,'}'
          lnote = 14
        end if
      end if
      if (ilvert .le. 9) then
        call addstr(notexq(1:lnote)//chax(48+ilvert),lnote+1,
     *              soutq,lsout)
      else
        write(notexq(lnote+1:lnote+4),'(a1,i2,a1)')'{',ilvert,'}'
        call addstr(notexq(1:lnote+4),lnote+4,soutq,lsout)
      end if
c
c  cancel out the stored time, to permit two arps at same time!
c
      itar(iarp) = -1
      return
      end
      subroutine chkarp(found1,ncrd,icrdat,icrdot,ivx,ip,isacc,isarp,
     *                  icashft)
      logical found1,isacc,isarp,btest
      integer icrdat(93),icrdot(93)
      found1 = .false.
c
c  icashft will be max left shift of accid's in chord notes.
c  Used only for spacing checks.
c  Will include left shift of chord note itself.
c  Rezero after use.
c
      do 18 icrd = 1 , ncrd
c
c  This if block cycles thru all chord notes on ivx,ip; then returns.
c
        if (iand(255,icrdat(icrd)) .eq. ip  .and.
     *          iand(15,ishft(icrdat(icrd),-8)) .eq. ivx) then
          found1 = .true.
c          isacc = isacc .or. btest(icrdat(icrd),19)
          if (btest(icrdat(icrd),19)) then
c
c  Accid on this chord note
c
            isacc = .true.
            irshft = igetbits(icrdot(icrd),7,20)
c
c  Include increment for notehead shift
c
            if (btest(icrdat(icrd),23)) then
              if (irshft .eq. 0) then
                irshft = 44
              else
                irshft=irshft-20
              end if
            end if
            if (irshft .ne. 0) then
c
c  Accid on chord note is shifted.  Include only left shift, in 20ths.
c
              if (irshft .lt. 64) icashft = max(icashft,64-irshft)
            end if
          end if
          isarp = isarp .or. btest(icrdat(icrd),25)
        else if (found1) then
          return
        end if
18    continue
      return
      end
      subroutine putshft(ivx,onoff,soutq,lsout)
      parameter (nm=12)
      common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
      character*80 soutq,notexq
      character*1 sq,chax
      logical onoff
      sq = chax(92)
c
c  Start user-defined offsets X(...): or X(...)S
c
      if (onoff) nudoff(ivx) = nudoff(ivx)+1
c
c  Xoff is in pts.  Round off to nearest .1.  Will use at end of shift.
c
      xoff = udoff(ivx,nudoff(ivx))
      xoff = sign(int(10.*abs(xoff)+.5)/10.,xoff)
      if (.not.onoff) xoff = -xoff
      if (xoff .lt. -9.95) then
        ifmt = 5
      else if (xoff.lt.-.95 .or. xoff.gt.9.95) then
        ifmt = 4
      else
        ifmt = 3
      end if
      write(notexq,'(f'//chax(48+ifmt)//'.1)')xoff
         call addstr(sq//'off{'//notexq(1:ifmt)//'pt}',8+ifmt,
     *                   soutq,lsout)
      return
      end
      subroutine outbar(i,jlast)
      character*1 chax
      nfmt = log10(i+.5)+2
      if (jlast+5+nfmt .lt. 80) then
        write(*,'(a5,i'//chax(48+nfmt)//',$)')'  Bar',i
        write(15,'(a5,i'//chax(48+nfmt)//',$)')'  Bar',i
        jlast = jlast+5+nfmt
      else
        write(*,'(/,a5,i'//chax(48+nfmt)//',$)')'  Bar',i
        write(15,'(/,a5,i'//chax(48+nfmt)//',$)')'  Bar',i
        jlast = 5+nfmt
      end if
      return
      end
      subroutine dotmov(updot,rtdot,soutq,lsout,iddot)
c
c  iddot = 0 for single dot, 1 for double
c
      character*80 soutq,notexq
      character*1 sq,chax
      sq = chax(92)
      lfmtup = lfmt1(updot)
      lfmtrt = lfmt1(rtdot)
      write(notexq,'(a37,f'//chax(48+lfmtup)//'.1,a2,f'//chax(48+lfmtrt)
     *    //'.1,a15)')
     * sq//'makeatletter'//sq//'def'//sq//'C@Point#1#2{'//sq//
     * 'PMXpt{',updot,'}{',rtdot,'}'//chax(48+iddot)//'}'//sq
     * //'makeatother'
c
c   Example of string just created:
c   \makeatletter\def\C@Point#1#2{\PMXpt{.5}{.5}}\makeatother\
c
      lnote = 54+lfmtup+lfmtrt
      call addstr(notexq(1:lnote),lnote,soutq,lsout)
      return
      end
      function lfmt1(x)
c
c  Computes total length of an "f" format with one decimal place.
c  First round to nearest 0.1
c
      if (abs(x) .lt. .001) then
        lfmt1 = 2
      else
        y = sign(.1*int(10*abs(x)+.5),x)
        lfmt1 = int(log10(1000*abs(y)+.001))
        if (y .lt. 0) lfmt1 = lfmt1+1
      end if
      return
      end
      subroutine getorn(lineq,iccount,iornq,iornq0,ornrpt,noffseg,
     *                  ip,ivx,noxtup,notcrd,nole)
c
c  iornq: Main note.  Do not alter if chord note, except turn on bit 23
c  iornq0: Store iorni + bit 23, in case of repeated ornaments
c  iorni: Internal use, 1st 21 bits of iornq or icrdorn, dep. on notcrd.
c  noffseg: horiz. offset for segno
c  nole: level of note w/ orn, used to ID the note/orn if there's a level shift.
c							

      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      character*1 charq,durq
      character*128 lineq
      logical ornrpt,negseg,noxtup,notcrd
c
c  Bits 0-13: (stmgx+Tupf._), 14: Down fermata, was F, 15: Trill w/o "tr", was U
c  16-18 Editorial sharp, flat, natural "oes,f,n"; 19-20: >^, 21 TBD
c
c  Set signal on main note that some note at this time has ornament.  ONLY used
c  in beamstrt to activate further tests for whether ihornb is needed.
c
      iornq = ibset(iornq,23)
c
c  Isolate 21 bits defining exisiting ornaments
c
      if (notcrd) then
        iorni = iand(4194303,iornq)
      else
        iorni = iand(4194303,icrdorn(ncrd))
      end if
      call getchar(lineq,iccount,charq)
      korn = index('stmgx+Tupf._)e:XXX>^',charq)
      if (korn .ne. 15) iorni = ibset(iorni,korn)
c
c  Note that korn=0 => charq='(', and we set bit 0.  if "e" (14), alter later
c    as follows: korn=16-18 for sfn, and or 21 for bare ?.
c  When this if-block is done, korn will = bit# of actual ornament (unless "?").
c
      if (korn .eq. 15) then
c
cc  Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-20 prev iornq
c  Turn off repeated ornament ('o:'), Replicate bits 0-3,5-15,19-21 prev iornq
c
c        iorni = ior(iorni,iand(iornq0,1638383))
        iorni = ior(iorni,iand(iornq0,3735535))
        ornrpt = .false.
        call getchar(lineq,iccount,durq)
c
c  durq will be ' '
c
      else if (korn .eq. 14) then
c
c  Editorial accidental
c
        call getchar(lineq,iccount,durq)
c        korn = 15+index('sfn',durq)
        korn = 15+index('sfn?',durq)
        if (korn .eq. 19) korn=21
        iorni = ibset(ibclr(iorni,14),korn)
        call getchar(lineq,iccount,durq)
        if (durq .eq. '?') then
c
c  This is "oe[s|f|n]".  Set 21st bit also.
c
          iorni = ibset(iorni,21)
          korn = korn+6
          call getchar(lineq,iccount,durq)
        end if
c        iorni = ibset(ibclr(iorni,14),korn)
      else if (korn.eq.4 .and. noxtup) then
c
c  segno. Check in pmxa for just 1/block & notcrd.  Get horiz. offset in points
c
        noffseg = 0
        negseg = .false.
        call getchar(lineq,iccount,durq)
        if (durq .ne. ' ') then
c
c  Segno shift is specified
c
          if (durq .eq. '-') then
            negseg = .true.
            call getchar(lineq,iccount,durq)
          end if
          call readnum(lineq,iccount,durq,fnum)
          noffseg = int(fnum)
          if (negseg) noffseg = -noffseg
        end if
      else if (korn .eq. 7) then
c
c  Trill.  Check in pmxa for notcrd.  Default is 1 noteskip long, with "tr"
c
        ntrill = ntrill + 1
        ivtrill(ntrill) = ivx
        iptrill(ntrill) = ip
        xnsktr(ntrill) = 1.
        call getchar(lineq,iccount,durq)
        if (durq .eq. 't') then
c
c  Convert to new internal symbol for non-'"tr" trill
c
          korn = 15
          iorni = ibset(ibclr(iorni,7),15)
          call getchar(lineq,iccount,durq)
        end if
        if (index('0123456789.',durq) .gt. 0) then
c
c  We have a number for the length
c
          call readnum(lineq,iccount,durq,xnsktr(ntrill))
        end if
      else if (korn.eq.10 .and. noxtup) then
c
c  Fermata
c
        call getchar(lineq,iccount,durq)
        if (durq .eq. 'd') then
          korn = 14
          iorni = ibset(ibclr(iorni,10),14)
          call getchar(lineq,iccount,durq)
        end if
      else
        call getchar(lineq,iccount,durq)
      end if
      if (index('+- :',durq) .eq. 0) then
        print*,'Unexpected character at end of ornament: ',durq
        stop 1
      end if
      if (index('+-',durq) .gt. 0) then
c
c  Shift ornament up or down
c
        nudorn = nudorn+1
c
c  Set bit 25 in iorni as a signal.  This may not really be necessary.
c
        iorni = ibset(iorni,25)
c
c  Assemble info to put in kudorn(nudorn) Bits 0-7:ip, 8-11:ivx, 12-18:nolev,
c     19-24: type of ornament to be shifted, 25-30: shift+32
c
        xofforn = 44-ichar(durq)
        iccount = iccount+1
        call readnum(lineq,iccount,durq,fnum)
        iofforn = nint(xofforn*fnum)
        kudorn(nudorn) = ip+ishft(ivx,8)+ishft(nole,12)+ishft(korn,19)
     *                   +ishft(iofforn+32,25)
      else if (durq .eq. ':') then
c
c  Turn on repeated ornaments
c
        ornrpt = .true.
c
c  Save the ornament value just set
c
        iornq0 = iorni
      end if
      if (notcrd) then
        iornq = ior(iornq,iorni)
      else
        icrdorn(ncrd) = ior(icrdorn(ncrd),iorni)
      end if
      return
      end
c      subroutine report(nsdat,isdat1,isdat2)
c      integer*4 isdat1(202),isdat2(202)
c      write(*,'(a)')
c     *  ' isd on? iv  kv   ip  id ud1 ud2 ndx ivo iho lev crd lhd rhd'
c      do 1 isdat = 1 , nsdat
c        isdata = isdat1(isdat)
c        ionoff = igetbits(isdata,1,11)
cc        iv = iand(7,isdata)
c        iv = igetbits(isdata,5,13)
c        kv = igetbits(isdata,1,12)+1
c        ip = igetbits(isdata,8,3)
c        idcode = igetbits(isdata,7,19)
c        iud1 = igetbits(isdata,1,26)
c        iud2 = igetbits(isdata,1,27)
c        ndxslur = igetbits(isdata,4,28)
c        isdatb = isdat2(isdat)
c        ivo = igetbits(isdatb,6,6)-32
c        iho = igetbits(isdatb,7,12)-64
c        lev = igetbits(isdatb,7,19)
c        icrd = igetbits(isdatb,1,0)
c        lhd = igetbits(isdatb,1,1)
c        irhd = igetbits(isdatb,7,2)
c        write(*,'(17i4)')isdat,ionoff,iv,kv,ip,idcode,iud1,iud2,ndxslur,
c     *                     ivo,iho,lev,icrd,lhd,irhd
c1     continue
c      print*
c      return
c      end
      function igetbits(isdata,iwidbit,ishift)
c
c  Extracts integer given by iwidbit bits of isdata, shifted by ishift, and
c  then added to ioff
c
      igetbits = iand(2**iwidbit-1,ishft(isdata,-ishift))
      return
      end
      subroutine setbits(isdata,iwidbit,ishift,ivalue)
c
c  Sets iwidbits of isdata, shifted by ishift, to ivalue
c
      ibase = 2**iwidbit-1
      if (ivalue.gt.ibase) then
        print*
        print*,'WARNING in setbits: ivalue > ibase'
        write(15,'(/,a)')'WARNING in setbits: ivalue > ibase'
      end if  
      isdata = iand(not(ishft(ibase,ishift)),isdata)
      isdata = ior(isdata,ishft(ivalue,ishift))
      return
      end
      subroutine precrd(ivx,ip,nolevm)
c
c  Analyzes chords, data to be used with slurs on chords and plain chords.
c
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      do 1 icrd1 = 1 , ncrd
        if (iand(255,icrdat(icrd1)) .eq. ip  .and.
     *      iand(15,ishft(icrdat(icrd1),-8)) .eq. ivx) go to 2
1     continue
      print*
      print*,'Failed to find first chord note!'
      stop
2     continue
      maxlev = nolevm
      minlev = nolevm
      do 3 icrd2 = icrd1 , ncrd
c
c  Exit loop if last note in this chord
c
        nolev = igetbits(icrdat(icrd2),7,12)
        maxlev = max(maxlev,nolev)
        minlev = min(minlev,nolev)
        if (icrd2 .eq. ncrd) go to 4
        if (igetbits(icrdat(icrd2+1),8,0) .ne. ip  .or.
     *      igetbits(icrdat(icrd2+1),4,8) .ne. ivx) go to 4
3     continue
      print*
      print*,'Failed to find last chord note!'
      stop
4     continue
c
c  Now icrd1, icrd2 define range of icrd for this chord.
c
      return
      end
      function lenstr(string,n)
      character*(*) string
      do 1 lenstr = n , 1 , -1
        if (string(lenstr:lenstr) .ne. ' ') return
1     continue
      lenstr = 0
      return
      end
      subroutine newvoice(jv,clefq,change)
      parameter (nm=12)
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      character*1 ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,isfig
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx
      common /comfb/ nfb(nm),t1fb(nm,20),t2fb(nm,20),ulfbq(nm,20),ifb
      character*1 ulfbq,clefq
      common /comcc/ ncc(nm),tcc(nm,10),ncmidcc(nm,10),
     *               ndotmv(nm),updot(nm,20),rtdot(nm,20)
      common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
      logical change
      nvmx(jv) = 1
      ivmx(jv,1) = jv
      itsofar(jv) = 0
      nnl(jv) = 0
      nfb(jv) = 0
      if (firstgulp .or. change) then
        ncmidcc(jv,1) = ncmidf(clefq)
      else
        ncmidcc(jv,1) = ncmidcc(jv,ncc(jv))
      end if
      tcc(jv,1) = 0.
      ncc(jv) = 1
      nudoff(jv) = 0
      ndotmv(jv) = 0
      do 5 j = 1 , 200
        irest(jv,j) = 0
        islur(jv,j) = 0
        ipl(jv,j) = 0
        nacc(jv,j) = 0
        iornq(jv,j) = 0
        if (jv.eq.1) isfig(j) = .false.
5     continue
      return
      end
      subroutine chkpm4ac(lineq,iccount,nacc,moved)
c
c  Called after getting +/-/</> in a note (not rest).  iccount is on the +-<>.
c  Sets moved=.true. and sets move parameters in nacc if necc: horiz only (bits
c    10-16) if < or >,  horiz and vert (bits 4-9) if two consecutive signed
c    numbers.  If moved=.true., iccount on exit is on end of last number.
c    If moved=.false., iccount still on +/-
c
      logical moved,ishorz
      character*128 lineq
      character*1 durq
      if (index('sfn',lineq(iccount-1:iccount-1)).gt.0 .and.
     *      index('0123456789.',lineq(iccount+1:iccount+1)).gt.0) then
c
c  Prior char was accid & next is #; this may be start of accidental shift.
c  Must test for "." above in case we get "<" or ">"
c
        ipm = index('- +< >',lineq(iccount:iccount))-2
        if (lineq(iccount+1:iccount+1).eq.'.' .and.
     *      index('0123456789',lineq(iccount+2:iccount+2)).eq.0) then
c
c  Rare case of [accid][+/-].[letter].  Bail out
c
          moved = .false.
          return
        end if
        ishorz = ipm .gt. 1
c
c  Save iccount in case it's not accid shift and we have to reset.
c
        icsav = iccount
        iccount = iccount+1
        call readnum(lineq,iccount,durq,fnum)
        if (ishorz .or. index('+-',durq).gt.0) then
c
c  This has to be accidental shift.  Set vert. shift.
c
          if (.not.ishorz) then
c
c  +/- syntax, both shifts set, vertical first
c
            call setbits(nacc,6,4,int(ipm*fnum+32.5))
            ipm = index('- +',durq)-2
            iccount = iccount+1
            call readnum(lineq,iccount,durq,fnum)
          else
c
c  </> syntax, only horiz set
c
            ipm = ipm-3
          end if
c
c  Set horiz. shift
c
          call setbits(nacc,7,10,int(20*(ipm*fnum+3.22)))
          iccount = iccount-1
          moved = .true.
        else
c
c  False alarm.  Reset everything and flow onward
c
          moved = .false.
          iccount = icsav
        end if
      else
c
c Either prior char was not 'sfn' or next was not digit, so take no action
c
        moved = .false.
      end if
      return
      end
      subroutine doacc(ihshft,ivshft,lshft,notexq,lnote,nacc,nolev,ncm)
      character*1 sq,chax
      character*3 acsymq
      character*8 noteq
      character*79 notexq
      logical btest,lshft
      sq = chax(92)
      if (ihshft .eq. -64) ihshft=0
c
c  If main note shifted left, so shift accid.  Terminate below, when acc. is don
c
      if (lshft) ihshft = ihshft-20
      if (ihshft .ne. 0) then
c
c  Accid must be shifted horizontally
c
        if (ihshft .lt. 0) then
          notexq = sq//'loffset{'
          ihshft = -ihshft
        else
          notexq = sq//'roffset{'
        end if
        hshft = .05*ihshft
        if (hshft .lt. 1.) then
          write(notexq(10:12),'(f3.2)')hshft
          lnote = 12
        else
          write(notexq(10:13),'(f4.2)')hshft
          lnote = 13
        end if
        notexq = notexq(1:lnote)//'}{'//sq
        lnote = lnote+3
      else
        notexq = sq
        lnote = 1
      end if
      if (btest(nacc,3)) then
        notexq = notexq(1:lnote)//'big'
        lnote = lnote+3
      end if
      call accsym(nacc,acsymq,lacc)
      notexq = notexq(1:lnote)//acsymq(1:lacc)
      lnote = lnote+lacc
      noleva = nolev
      if (ivshft .ne. 0) noleva = noleva+ivshft-32
      call notefq(noteq,lnoten,noleva,ncm)
      if (lnoten .eq. 1) call addblank(noteq,lnoten)
      notexq = notexq(1:lnote)//noteq(1:lnoten)
      lnote = lnote+lnoten
      if (ihshft .ne. 0) then
c
c  Terminate horizontal shift
c
        notexq = notexq(1:lnote)//'}'
        lnote = lnote+1
      end if
      return
      end
      subroutine getdyn(ivx,ip,irest,lineq,iccount)
      common /comdyn/ ndyn,idyndat(99)
      character*1 durq,chax
      character*4 dynsymq
      character*128 lineq
c
c  Get info for dynamic mark.  Enter after getting "D", iccount sits on "D"
c  Bits in idyndat are as follows
c    00-03 ivx
c    04-11 ip
c    12-15 code for type of mark
c      1-12 => pppp,ppp,pp,p,mp,mf,f,fp,sf,ff,fff,ffff
c    16    flag for vertical offset
c    17-22 vertical offset + 32 , \internote
c    23    flag for horizontal offset
c    24-30 (horizontal offset)/10 + 6.4 notehead widths
c
      irest = ibset(irest,26)
      ndyn = ndyn+1
      idyn = ivx
      call setbits(idyn,8,4,ip)
      do 1 iend = iccount+2 , 128
        ipm = index('- +',lineq(iend:iend))
        if (ipm .gt. 0) go to 2
1     continue
2     continue
      read(lineq(iccount+1:iend-1),'(a'//chax(47+iend-iccount)//')')
     *   dynsymq
      idno = (index('ppppppp pp  p   mp  mf  f   fp  sf  ff  fff ffff',
     *         dynsymq)+3)/4
      call setbits(idyn,4,12,idno)
      iccount = iend
      if (ipm .ne. 2) then
c
c  There is a vertical shift
c
        idyn = ibset(idyn,16)
        iccount = iccount+1
        call readnum(lineq,iccount,durq,fnum)
        idno = nint(fnum)
        call setbits(idyn,6,17,(ipm-2)*idno+32)
        ipm = index('- +',durq)
        if (ipm .ne. 2) then
c
c  There is a horizontal shift
c
          idyn = ibset(idyn,23)
          iccount = iccount+1
          call readnum(lineq,iccount,durq,fnum)
          idno = nint(10*fnum)
          call setbits(idyn,7,24,(ipm-2)*idno+64)
        end if
c
c  iccount should be on the blank at the end of the entire symbol
c
      end if
      idyndat(ndyn) = idyn
      return
      end
      subroutine dodyn(ivx,ip,nolev,ncm,ipl,islur,nvmx,nv,beamon,soutq,
     *                 lsout)
c
c  Inputs are array *elements*
c
      common /comdyn/ ndyn,idyndat(99)
      common /comtrill/ ntrill,ivtrill(18),iptrill(18),xnsktr(18),
     *                ncrd,icrdat(93),icrdot(93),icrdorn(93),nudorn,
     *                kudorn(63),minlev,maxlev,icrd1,icrd2
      logical btest,beamon
      character*1 udqq,chax
      character*4 dynstrq
      character*8 noteq
      character*48 dyntablq
      character*79 notexq
      character*80 soutq
      data dyntablq /'ppppppp pp  p   mp  mf  f   fp  sf  ff  fff ffff'/
c
c  Find in list
c
      do 1 idyn = 1 , ndyn
        if (iand(idyndat(idyn),15) .eq. ivx) then
          if (igetbits(idyndat(idyn),8,4) .eq.ip) go to 2
        end if
1     continue
      print*,'problem finding idyndat'
      stop 1
2     continue
      idynd = idyndat(idyn)
      ivx = iand(15,idynd)
      if (.not.beamon) then
        if (udqq(nolev,ncm,islur,nvmx,ivx,nv) .eq. 'u') then
          if (.not.btest(ipl,10)) then
            lbot = min(nolev-1,ncm-4)
          else
            lbot = min(minlev-1,ncm-4)
          end if
        else
          if (.not.btest(ipl,10)) then
            lbot = min(nolev-7,ncm-4)
          else
            lbot = min(minlev-7,ncm-4)
          end if
        end if
      else
c       if ulq = 'u' then
          if (.not.btest(ipl,10)) then
            lbot = min(nolev-1,ncm-4)
          else
            lbot = min(minlev-1,ncm-4)
          end if
c       else
c         down beam stuff
c       end if
      end if
      lbot = lbot-5
c
c  Check for vertical offset
c
      if (btest(idynd,16)) lbot = lbot-32+igetbits(idynd,6,17)
      if (btest(idynd,23)) then
c
c  Horizontal offset
c
        hoff = (igetbits(idynd,7,24)-64)*.1
        lform = lfmt1(hoff)
        notexq = chax(92)//'roffset{'
        write(notexq(10:9+lform),'(f'//chax(48+lform)//'.1)')hoff
        call addstr(notexq(1:9+lform)//'}{',11+lform,soutq,lsout)
      end if
      call addstr(chax(92)//'zcharnote',10,soutq,lsout)
      call notefq(noteq,lnoten,lbot,ncm)
      if (lnoten .eq. 1) then
        noteq = '{'//noteq(1:1)//'}'
        lnoten = 3
      end if
      call addstr(noteq(1:lnoten),lnoten,soutq,lsout)
      id = 4*igetbits(idynd,4,12)
      dynstrq = dyntablq(id-3:id)
      id = lenstr(dynstrq,4)
      call addstr('{'//chax(92)//dynstrq(1:id)//'}',id+3,soutq,lsout)
      if (btest(idynd,23)) call addstr('}',1,soutq,lsout)
      return
      end
      function levrn(nolev,irest,iud,ncm,mult)
c
c  Used for placing numbers in xtups.  Returns note level if not a rest,
c  else level of top or bottom of rest symbol opposite beam.  iud=-1 for upstm.
c
      logical btest
      if (.not.btest(irest,0)) then
        levrn = nolev
      else
c
c  Restlevel is -4, 0, 2 or 100+offset.  First get offset from 1-voice default.
c
        if (mult .gt. 0) then
          if (mult .eq. 2) then
            ioff = -1+2*iud
          else if (mult .ne. 4) then
            ioff = iud*mult
          else
            ioff = 1+4*iud
          end if
        else
c
c  May need to futz with this later for non-beamed xtups (quarter, half rests)
c
          ioff = iud*2
        end if
        levrn = mod(nolev+20,100)-20+ncm+ioff
      endif
      return
      end
      subroutine getx(lineq,iccount,irest,shifton,wheadpt,
     *                iornq1,ivx,irest1,itsofar,ntup,itup,nnodur,dotq)
      parameter(nm=12)
c
c  Parse "X" commands.  Ignore all "B"; "P" means to ignore whole symbol.
c  In scor2prt, must strip out "P", copy only "B" and "P"-type "X"-symbols.
c  Since during getnote phase time is integer itsofar, which is not updated 
c    during xtups, we use itup and ntup to get actual time.  On entry, ntup=0 if
c    not in xtup.
c      
      common /comudsp/udsp(50),tudsp(50),nudsp,udoff(nm,20),nudoff(nm)
      logical shifton,colon,ess,number
      character*128 lineq
      character*1 charq,durq,dotq
      colon = .false.
      ess = .false.
      number = .false.
      nextbl = iccount+index(lineq(iccount:128),' ')-1
      if (index(lineq(iccount:nextbl),'P') .gt. 0) then
c
c  "Parts only", ignore entire symbol
c
        iccount = nextbl
        return
      end if
1     call getchar(lineq,iccount,charq)
      if (charq.eq.'B') then
c
c  "Both parts and score," ignore character
c
        go to 1
      else if (charq .eq. ':') then
        colon = .true.
        go to 1
      else if (charq .eq. 'S') then
        ess = .true.
        go to 1
      else if (index('+-.0123456789',charq) .gt. 0) then
        number = .true.
        if (charq.eq.'-') iccount = iccount+1
        call readnum(lineq,iccount,durq,fnum)
        if (charq .eq. '-') fnum = -fnum
        if (durq .ne. 'p') then
          fnum = fnum*wheadpt
          iccount = iccount-1
        end if
        go to 1
      end if
c
c  charq must be blank, so done parsing
c
      if (.not.ess .and. .not.colon) then
c
c  Ordinary hardspace.  Goes before next note.
c   (Later, at "|" or "/", check for presence and switch to udoff if there!)
c
        nudsp = nudsp+1
        iornq1 = ibset(iornq1,26)
        udsp(nudsp) = fnum
        tudsp(nudsp) = itsofar
        if (ntup .gt. 0) tudsp(nudsp) = tudsp(nudsp)
     *                       +float(itup-1)/ntup*ifnodur(nnodur,dotq)
      else if (.not.number) then
c
c  Must be "X:"  End a group offset.
c
        irest = ibset(irest,17)
        shifton = .false.
        return
      else
c
c  Only other possibility is start offset, "S" for single, ':' for multiple
c
        nudoff(ivx) = nudoff(ivx)+1
        udoff(ivx,nudoff(ivx)) = fnum
        if (ess) then
          irest1 = ibset(irest1,15)
        else
          irest1 = ibset(irest1,16)
          shifton = .true.
        end if
      end if
      return
      end
      function ntindex(line,s2q,lenline)
c
c  Returns index(line,s2q) if NOT in TeX string, 0 otherwise
c
      character*(*) s2q,line
      character*1 chax
      logical intex
      ndxs2 = index(line,s2q)
      ndxbs = index(line,chax(92))
      if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then
        ntindex = ndxs2
      else
c
c  There are both bs and s2q, and bs is to the left of sq2. So check bs's to
c  right of first: End is '\ ', start is ' \'
c
        len = lenstr(line,lenline)
        intex = .true.
        do 1 ic = ndxbs+1 , len
          if (ic .eq. ndxs2) then
            if (intex) then
              ntindex = 0
              ndxs2 = index(line(ic+1:len),s2q)+ic
            else
              ntindex = ndxs2
              return
            end if
          else if (intex .and. line(ic+1:ic+2).eq.chax(92)//' ') then
            intex = .false.
          else if (.not.intex .and. line(ic+1:ic+2).eq.' '//chax(92))
     *           then
            intex = .true.
          end if
1       continue
      end if
      return
      end
c      integer*4 function mytime()
c      CHARACTER(10) tq
c      CALL DATE_AND_TIME(TIME=tq)
c      read(tq,'(2i2,f6.3)')ih,im,ts
c      mytime = 1000*(ts+60*(im+60*ih))
c      return
c      end  
      subroutine getbuf(lineq)
      character*(*) lineq
      character*65536 bufq
      integer*2 lbuf(2000)
      common /inbuff/ ipbuf,ilbuf,nlbuf,lbuf,bufq
      lineq = bufq(ipbuf+1:ipbuf+lbuf(ilbuf))
      ipbuf = ipbuf+lbuf(ilbuf)
      ilbuf = ilbuf+1
      return
      end
      subroutine printl(string)
      character*(*) string
c
c  Send string to console and to log file
c
      print*,string
      write(15,'(a)')string
      return
      end
      character*1 function chax(n)
c
c The only reason for this seemingly do-nothing function is to get around an
c  apparent bug in the Visual Fortran Standard Edition 5.0.A compiler!
c
      chax = char(n)
      return
      end
      function fnote(nodur,ivx,ip)
c
c  This return the real duration of a note
c
      parameter (nm=12)
      integer*4 nodur(nm,200)
      ipback = ip
      if (nodur(ivx,ip) .gt. 0) then
        if (ip .gt. 1) then
c
c  Check if this is last note of xtup
c
          if (nodur(ivx,ip-1).eq.0) then
            ipback = ip-1
            go to 2
          end if
        end if
        fnote = nodur(ivx,ip)
        return
      end if
2     continue
c
c  Count back to prior non zero note. Start at ip to avoid neg index if ip=1 
c
      do 1 ip1m1 = ipback , 1 , -1
        if (nodur(ivx,ip1m1) .gt. 0) go to 4
1     continue
4     continue      
c
c  count forward to next non-0 nodur. Start at ip in case last note of xtup. 
c
      do 3 iip = ip , 200
        if (nodur(ivx,iip) .gt. 0) then
          fnote = nodur(ivx,iip)/float(iip-ip1m1)
          return
        end if
3     continue
      print*,'Bad error in fnote'
	iz = 0
      kkk = nodur(iz,iz)
      stop
      end
      function getsquez(n,ntot,space,tnote,to)
      real*4 tnote(200),to(200)
      common /comtol/ tol
c
c  Get the squez factor by checking space against tgovern=minimum duration
c    of all notes sounding at time of n-th note in the list.  
c  The starting time of base increment is to(n) and ending time is to(n)+space
c  Sounding notes are those that start at or before to(n) .and. end at or
c    after tend=to(n)+space
c  Since notes are ordered by increasing start times, as soon as we find one 
c    that starts too late, we are done checking.
c  
      tgovern = 1000.
      tend = to(n)+space
      do 1 in = 1 , ntot
c
c  Since to() is ordered by start times, exit loop after first note that 
c    starts later than note of interest.
c

        if (to(in) .gt. to(n)+tol) go to 2
        if (to(in)+tnote(in) .gt. tend-tol) then
c
c  If here, this note overlaps and must be tested.  
c
          tgovern = min(tgovern,tnote(in))
        end if
1     continue
2     continue
      getsquez = space/tgovern
      return
      end
      logical function isdotted(nodur,ivx,ip)
      parameter (nm=12)
c
c  Function returns true if note is dotted or double-dotted.
c    Return false for any xtuplet.
c
      common /comtol/ tol
      integer*4 nodur(nm,200)
      if (nodur(ivx,ip) .eq. 0) then
        isdotted = .false.
        return
      else if (ip .gt. 1) then
        if (nodur(ivx,ip-1) .eq. 0) then
          isdotted = .false.
          return
        end if
      end if
c
c  Ruled out all xtups, so is dotted or double-dotted if not a power of 2.
c
      isdotted = 
     *    mod(alog(float(nodur(ivx,ip)))/.69314718+.5*tol,1.) .gt. tol
      return
      end
      subroutine topfile(basenameq,lbase,nv,clefq,noinst,musicsize,
     *                   xinstf1,mtrnmp,mtrdnp,vshrink,fbar)
      parameter (nm=12)
      common /comlast/ islast
      logical islast
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,idsig,
     *   lnam(nm),inameq(nm)
      common /comarp/ narp,itar(8),ivar1(8),levar1(8),ncmar1(8),xinsnow,
     *                lowdot
      common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
      character*79 inameq
      character*24 basenameq,fmtq
      character*5 fbarq
      character*1 clefq(nm),sq,chax
      common /comstart/ facmtr
      logical vshrink,lowdot,rename
      sq = chax(92)
      vshrink = xinstf1.gt.20.
      if (vshrink) then
        xinsnow = 10.
      else
        xinsnow = xinstf1
      end if
      if (.not.islast) return 
      write(11,'(a)')'%%%%%%%%%%%%%%%%%'
      write(11,'(a)')'%'
      write(11,'(a)')'% '//basenameq(1:lbase)//'.tex'
      write(11,'(a)')'%'
      write(11,'(a)')'%%%%%%%%%%%%%%%%'
      write(11,'(a)')sq//'input musixtex'
      write(11,'(a)')sq//'input pmx'
      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=',nint(widthpt),'pt'
      write(11,'(a6,i'//chax(49+int(log10(height+.1)))//',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}'
      if (noinst .lt. 10) then
        write(11,'(a19,i1,a1)')sq//'def'//sq//'nbinstruments{',
     *       noinst,'}'
      else
        write(11,'(a19,i2,a1)')sq//'def'//sq//'nbinstruments{',
     *     noinst,'}'
      end if
      iv = 0
      do 1 iinst = 1 , noinst
        nstaves = nsperi(iinst)
        if (iinst .lt. 10) then
          write(11,'(a)')sq//'setstaffs'//chax(48+iinst)
     *        //chax(48+nstaves)
        else
          write(11,'(a11,i2,a)')sq//'setstaffs{',iinst,'}'
     *        //chax(48+nstaves)
        end if
        iv = iv+1
        if (nstaves .eq. 1) then
          fmtq = chax(48+numclef(clefq(iv)))
          lfmtq = 1
        else
          fmtq = '{'//chax(48+numclef(clefq(iv)))
          lfmtq = 2
          do 2 k = 2 , nstaves
            iv = iv+1
            fmtq = fmtq(1:lfmtq)//chax(48+numclef(clefq(iv)))
            lfmtq = lfmtq+1
2         continue
          fmtq = fmtq(1:lfmtq)//'}'
          lfmtq = lfmtq+1
        end if
        if (iinst .lt. 10) then
          write(11,'(a)')sq//'setclef'//chax(48+iinst)//fmtq(1:lfmtq)
        else
          write(11,'(a9,i2,a)')sq//'setclef{',iinst,'}'//fmtq(1:lfmtq)
        end if
        do 3 lname = 79 , 2 , -1
          if (inameq(iinst)(lname:lname) .ne. ' ') go to 4
3       continue
4       continue
        lnam(iinst) = lname
        if (iinst .lt. 10) then
          write(11,'(a8,i1,a)')sq//'setname',iinst,
     *         '{'//inameq(iinst)(1:lname)//'}'
        else
          write(11,'(a9,i2,a)')sq//'setname{',iinst,
     *         '}{'//inameq(iinst)(1:lname)//'}'
        end if
1     continue
      write(11,'(a18,i2,a2)')sq//'generalsignature{',isig,'}%'
      call wgmeter(mtrnmp,mtrdnp)
      ipi = nint(fracindent*widthpt)
      if (ipi .lt. 10) then
        write(11,'(a11,i1,a2)')sq//'parindent ',ipi,'pt'
      else if (ipi .lt. 100) then
        write(11,'(a11,i2,a2)')sq//'parindent ',ipi,'pt'
      else
        write(11,'(a11,i3,a2)')sq//'parindent ',ipi,'pt'
      end if
      write(11,'(a)')sq//'elemskip1pt'//sq//'afterruleskip'
     *      //fbarq//'pt'//sq//'beforeruleskip0pt'//sq//'relax'
      if (.not.vshrink) then
        if (xinstf1 .lt. 9.95) then
          fmtq = '(a,f3.1,a)'
        else
          fmtq = '(a,f4.1,a)'
        end if
        write(11,fmtq)sq//'stafftopmarg0pt'//sq//'staffbotmarg0pt'
     *       //sq//'interstaff{',xinstf1,'}'//sq//'relax'
      else 
        write(11,'(a)')sq//'stafftopmarg0pt'//
     *         sq//'staffbotmarg5'//sq//'Interligne'//sq//
     *         'interstaff{10}'//sq//'relax'
      end if
      if (nv.eq.1) write(11,'(a)')sq//'nostartrule'
      write(11,'(a)')sq//'readmod{'//basenameq(1:lbase)//'}'
      write(11,'(a)')sq//'startmuflex'//sq//'startpiece'//sq//
     *      'addspace'//sq//'afterruleskip%'
      return
      end
      subroutine findeonk(nptr1,nptr2,wovera,xelsk,dtmin,dtmax,eonk0)
      parameter (nkb=600)
c
c  Compute an exponent eonk for use in the "flattened" formula for elemskips
c   vs time.  We must solve the eqution f = 0.  Initial quess is eonk0.
c
      logical gotclef
      common /c1omnotes/ nnodur,wminnh(nkb),nnpd(2000),durb(2000),iddot,
     *     nptr(nkb),ibarcnt,mbrest,ibarmbr,
     *     ibaroff,udsp(nkb),wheadpt,gotclef,sqzb(2000)
      common /comtol/ tol
      common /comeon/ eonk,ewmxk
      eonk = eonk0
      niter = 0
1     continue
      ewmxk = f1eon(dtmax)**eonk
      niter = niter+1
      esum = 0.
      desum = 0.
      do 2 iptr = nptr1 , nptr2
        targ = durb(iptr)/sqzb(iptr)
        esum = esum+nnpd(iptr)*sqzb(iptr)*feon(targ)
        detarg = sqrt(targ/2*(dtmax/targ)**eonk)*alog(dtmax/targ)
        desum = desum+nnpd(iptr)*sqzb(iptr)*detarg
2     continue
      f = wovera*feon(dtmin)-xelsk-esum
      fp = wovera*sqrt(dtmin/2*(dtmax/dtmin)**eonk)*alog(dtmax/dtmin)
     *     -desum 
      if (abs(fp).lt.tol .or. abs(eonk-.5).gt..5 .or. niter.gt.100) then
        call printl(
     *     'Error in findeonk.  Please send source to Dr. Don')
        eonk = 0.
        ewmxk = 1.
        return
      end if
      dsoln = -f/fp
      if (abs(dsoln) .lt. .1*tol) return
c
c  Not converged yet, try again
c
      eonk = eonk+dsoln
      go to 1
      end
      subroutine istring(i,string,len)
c
c  Returns string with integer only if length is 1, otherwise enclosed in
c   brackets.  
c
      character*(*) string
      if (i .ne. 0) then
        len = alog10(abs(i)*1.0001)+1
        if (i .lt. 0) len = len+1
      else
        string = '0'
        len = 1
        return
      end if
      if (len .eq. 1) then
        string = char(48+i)
      else
        string = '{'
        write(string(2:1+len),'(i'//char(48+len)//')')i
        string = string(1:len+1)//'}'
        len = len+2
      end if
      return
      end
c
c
      subroutine addmidi(icm,nolev,iacc,isig,time,rest,endrest)
      parameter(nm=12,mv=24576)
      integer*2 mmidi,itk(25)
      integer*4 itiesav(5,100)
      character*1 notenumq
      logical endrest,eximacc,it1found
      logical rest
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
      logical slmon,dbltie
      common /comslm/ levson(0:nm),levsoff(0:nm),imidso(0:nm),
     *       naccbl(0:nm),laccbl(0:nm,10),jaccbl(0:nm,10),nusebl,
     *       slmon(0:nm),dbltie
      common /comevent/ miditime,lasttime
      common /comdiag/ n69(0:nm)
c
c  Following variables are local but must be saved.  I hope they are.
c  (3/18/00) With g77 they are not, so add a common block here.
c
      integer*2 ipslon(0:nm),lusebl(10),jusebl(10)
      common /comips/ ipslon,lusebl,jusebl
c
c  Cancel out barline accidentals if there's a rest.
c
      if (rest) naccbl(icm) = 0
c
c  Special path to insert dummy rest at end of a section
c
      if (endrest) go to 20
c
      do 7 ion = 0 , nmidcrd
c
c  check if this is only to get pitch of a chord note
c
        if (notmain) go to 6
c
c  check for rest
c
        if (rest) then
c
c  Will not put in a note, but must update timing
c
          if (.not.restpend(icm)) then
c
c  First rest in sequence, save the time
c
            restpend(icm) = .true.
            trest(icm) = time
          else 
            trest(icm) = trest(icm)+time
          end if
c
c  Note: code checkers don't like the above due to calling addmidi(trest(icm))
c    but this only happens if rest at end of section (endrest=.true.) (called
c    from getmidi(), in which case these above lines are bypassed.
c
          return
        end if
c
c  time tics
c
        if (imidi(icm).gt.0 .and. ion.eq.0) then
          idur = mgap
        else
          idur = 0
        end if
        if (restpend(icm)) then
          restpend(icm) = .false.
          idur = idur+nint(15*trest(icm))
        end if
c
c  time to start of note
c
        idurvar = isetvarlen(idur,nby2on)
        if (nby2on .gt. 4) then
          print*,'You got >4 bytes, something is bogus.'
          stop 1
        end if
        imidi(icm) = imidi(icm)+1
        do 2 i = 1 , nby2on
c
c  imidi points to cell before highest (leftmost) byte.  Start with lowest byte 
c    at far right, fill in backwards
c
          mmidi(icm,imidi(icm)+nby2on-i) = mod(idurvar,256)
          if (nby2on .gt. 1) idurvar = idurvar/256
2       continue
        imidi(icm) = imidi(icm)+nby2on-1
c
c  Note-on signal
c  
        imidi(icm) = imidi(icm)+1
        mmidi(icm,imidi(icm)) = 9*16+icm
c
c  Entry point for chord note pitch determination
c
6       continue
c
c  Get midi pitch.  On chord iteration, only do this first time (main note),
c  since pitch was already computed for nonmain chord notes.
c
        if (ion .eq. 0) then
          ipsav = nolev*12./7+11
          ipsav0 = ipsav
          if (isig .ne. 0) then
c
c  Adjust for signature 
c
            notenumq = char(48+mod(nolev,7))
            if (isig.ge.index('4152630',notenumq)) then
              ipsav = ipsav+1
            else if (-isig.ge.index('0362514',notenumq)) then
              ipsav = ipsav-1
            end if
          end if
c
c  Deal with accidentals.  
c
c  iacc   0   1   2   3   4   5   6   7
c effect  X   fl  sh  na  X  dfl dsh  X
c iashft  X   -1  1   0   X  -2   2   X
c
          jacc = 0
          eximacc = .false.
          if (iacc .gt. 0) then
c
c  Adjust key-sig-adjusted pitch for explicit accidental (and exit)
c
            jacc = iashft(iacc)
            eximacc = .true.
            if (.not.relacc) jacc = jacc+ipsav0-ipsav
c		   
c  (Above) Shift applies to diatonic pitch but will be added to adjusted one
c
          else if (naccim(icm) .gt. 0) then
c
c  Possible implicit accidental from earlier in the bar
c    Check for prior accid in this bar at this note level
c
            do 3 kacc = 1 , naccim(icm)
              if (laccim(icm,kacc) .eq. nolev) then
                jacc = jaccim(icm,kacc)
                eximacc = .true.
                if (.not.relacc) jacc = jacc+ipsav0-ipsav
                go to 4
              end if
3           continue
4           continue
          end if
c
c  Must split off the following if block from those above because chord
c  notes can cause naccim>0, forcing us to miss other chord note's
c  accross-bar-line accidental
c
          if (naccbl(icm).gt.0 .and. .not.eximacc) then
c
c  Possible carryover accid from prior bar (or prior same-pitch note).    
c
            do 21 kacc = 1 , naccbl(icm)
              if (laccbl(icm,kacc) .eq. nolev) then
                jacc = jaccbl(icm,kacc)
c
c  Since we are *using* the bar-line accid, must flag it to be saved for next.
c 
                nusebl = nusebl+1
                jusebl(nusebl) = jacc
                lusebl(nusebl) = nolev
                if (.not.relacc) jacc = jacc+ipsav0-ipsav
                go to 22
              end if
21          continue
22          continue
          end if
          ipsav = ipsav+jacc
        end if
        if (notmain) then
          mcpitch(nmidcrd) = ipsav
c
c  Save pitch for tie checks
c
          if (levson(icm).eq.nolev.and..not.slmon(icm)) 
     *           ipslon(icm) = ipsav
        else 
          imidi(icm) = imidi(icm)+1
          if (ion.eq.0) then
            mmidi(icm,imidi(icm)) = ipsav
            if (levson(icm).eq.nolev.and..not.slmon(icm)) 
     *           ipslon(icm) = ipsav
          else
            mmidi(icm,imidi(icm)) = mcpitch(ion)
          end if
        end if
        if (ion .eq. 0) then
c
c  Only record accids for non-chords, main chord note during chord iteration
c    and chordnotes on first call but not during iteration
c
          if (iacc.gt.0) then
c
c  Set marker for accidental for possible continuations later this bar
c    but first check and clear earlier ones on same note. 
c
            do 23 kacc = 1 , naccim(icm)
              if (laccim(icm,kacc) .eq. nolev) then
                do 24 macc = kacc , naccim(icm)-1
                  laccim(icm,macc) = laccim(icm,macc+1)
                  jaccim(icm,macc) = jaccim(icm,macc+1)
24              continue
                go to 25
              end if
23          continue
            go to 26
25          continue
            naccim(icm) = naccim(icm)-1
26          continue
c
c  Flag new accidental
c
            naccim(icm) = naccim(icm)+1
            laccim(icm,naccim(icm)) = nolev
            jaccim(icm,naccim(icm)) = iashft(iacc)
          end if
c
c  Bail if this is a chord note on the first call (from docrd)
c
          if (notmain) return
        end if
c
c  Vel
c
        imidi(icm) = imidi(icm)+1
        mmidi(icm,imidi(icm)) = 127
        call chkimidi(icm)
7     continue
c
c  For tie checks
c
      if (levson(icm).gt.0.and..not.slmon(icm)) imidso(icm) = imidi(icm)
c
c  Entry point for special rests at section ends (endrest=T)
c
20    continue
c
c  Now insert all the ends
c
      do 8 ioff = 0 , nmidcrd
        if (ioff .eq. 0) then
c
c  time to end
c
          idur1 = nint(15*time)    
          if (.not.endrest .or. miditime.eq.nint(15*trest(icm))) then 
            idur = idur1-mgap
          else
            idur = idur1
          end if
          if (idur1 .eq. 69) then
c
c  Deal with roundoff problem with 7-tuplets
c
            n69(icm) = n69(icm)+1
            if (mod(n69(icm)+6,7) .gt. 3) idur = 58
          end if
          idurvar = isetvarlen(idur,nby2off)
          if (nby2off .gt. 4) then
            print*,'You got >4 bytes, something is bogus.'
            stop 1
          end if
          imidi(icm) = imidi(icm)+1
          call chkimidi(icm)
          do 1 i = 1 , nby2off
            mmidi(icm,imidi(icm)+nby2off-i) = mod(idurvar,256)
            if (nby2off .gt. 1) idurvar = idurvar/256
1         continue
          imidi(icm) = imidi(icm)+nby2off-1
        else
c
c  Inserting end of chord note, delta time is 0
c
          imidi(icm) = imidi(icm)+1
          mmidi(icm,imidi(icm)) = 0
        end if
c
c  Note off
c
        imidi(icm) = imidi(icm)+1
        mmidi(icm,imidi(icm)) = 8*16+icm
c
c  Pitch
c
        imidi(icm) = imidi(icm)+1
        if (ioff .eq. 0) then
          mmidi(icm,imidi(icm)) = ipsav
        else
          mmidi(icm,imidi(icm)) = mcpitch(ioff)
        end if
c
c  Vel
c
        imidi(icm) = imidi(icm)+1
        mmidi(icm,imidi(icm)) = 0
        call chkimidi(icm)
        if (endrest) return
c
c      print*,'Off, icm,imidi,ipsav,idur:',icm,imidi(icm),ipsav,time
c
8     continue
      naccbl(icm) = nusebl
      if (nusebl .gt. 0) then
c
c  Fix tables of "bar-line" accids that are saved due to consecutive notes.
c
        do 30 kacc = 1 , nusebl
          laccbl(icm,kacc) = lusebl(kacc)
          jaccbl(icm,kacc) = jusebl(kacc)
30      continue 
        nusebl = 0
      end if
c
c  Begin tie checks
c
      if (slmon(icm)) then
c
c  Prior note had a slur start
c
        if (levson(icm).eq.levsoff(icm) .and. iacc.eq.0) then
c
c  We have a tie! (Assumed there would be no accidental on tie-ending note)
c  Make a list of times of all events back to the one starting at imidso+1, 
c    which is at or before where the tie started.  Ident tie start and stop by
c    comparing pitches.  Save the 4 pieces of data in itiesav(1...4,nsav4tie)
c    Store actual time in itiesav(5,nsav4tie), using itiesav(1,1) as initial 
c    time.
          nsav4tie = 0
          imidt = imidso(icm)
10        nsav4tie = nsav4tie+1
          itiesav(1,nsav4tie) = igetvarlen(mmidi,icm,imidt,nbytes)
          imidt = imidt+nbytes
          do 11 j = 1 , 3
            itiesav(j+1,nsav4tie) = mmidi(icm,imidt+j)
11        continue
          imidt = imidt+3
          if (nsav4tie .eq. 1) then
            itiesav(5,1) = itiesav(1,1)
          else
            itiesav(5,nsav4tie) = itiesav(1,nsav4tie)+
     *                              itiesav(5,nsav4tie-1)
          end if
          if (imidt .ne. imidi(icm)) go to 10
c
c  Find which two pitches agree with saved slur pitch.
c
          it1found = .false.
          do 12 it2 = 1 , nsav4tie
            if (itiesav(3,it2) .eq. ipslon(icm)) then
              if (it1found) go to 13
              it1 = it2
              it1found = .true.
            end if
12        continue
          print*,'Failed to find tied notes; kluging'
c          stop 1
          it1 = nsav4tie+1
          it2 = nsav4tie+1
13        continue
c
c  List the positions we want to keep
c
          jsav = 0
          do 14 isav = 1 , nsav4tie
            if (isav.eq.it1 .or. isav.eq.it2) go to 14
            jsav = jsav+1
            itk(jsav) = isav
14        continue
          nsav4tie = nsav4tie-2
c
c  Now dump events it1 & it2, recompute times, restack mmidi.         
c
          imidi(icm) = imidso(icm)
          do 15 isav = 1 ,nsav4tie
            if (isav .eq. 1) then
              idurvar = isetvarlen(itiesav(5,itk(isav)),nbytes)
            else
              idurvar = isetvarlen(itiesav(5,itk(isav))-
     *                             itiesav(5,itk(isav-1)),nbytes)
            end if
            imidi(icm) = imidi(icm)+1
            do 16 i = 1 , nbytes
              mmidi(icm,imidi(icm)+nbytes-i) = mod(idurvar,256)
              if (nbytes .gt. 1) idurvar = idurvar/256
16          continue
            imidi(icm) = imidi(icm)+nbytes-1
            do 17 i = 2 , 4
              imidi(icm) = imidi(icm)+1
              mmidi(icm,imidi(icm)) = itiesav(i,itk(isav))
17          continue
15        continue
        end if
        slmon(icm) = .false.
        levsoff(icm) = 0
        if (.not.dbltie) levson(icm) = 0
      end if
      if (levson(icm).gt.0) slmon(icm) = .true.
      if (nmidcrd .gt. 0) nmidcrd = 0
      return
      end
      function igetvarlen(mmidi,icm,imidi,nbytes)
c
c  Gets variable-length integer starting in mmidi at imidi+1. Returns nbytes.
c
      parameter (nm=12,mv=24576)
      integer*2 mmidi(0:nm,mv)
      igetvarlen = 0
      do 1 nbytes = 1 , 4
        igetvarlen = 128*igetvarlen
     *               +iand(127,mmidi(icm,imidi+nbytes))
c     *               +iand(127,longi(mmidi(icm,imidi+nbytes)))
        if (.not.btest(mmidi(icm,imidi+nbytes),7)) return
c        if (.not.btest(longi(mmidi(icm,imidi+nbytes)),7)) return
1     continue
      print*,'Messup in igetvarlen'
      stop 1
      end
      function isetvarlen(idur,nbytes)
      isetvarlen = 0
      itemp = idur
      do 1 nbytes = 1 , 4
        isetvarlen = isetvarlen + iand(itemp,127)*256**(nbytes-1)
        itemp = ishft(itemp,-7)
        if (itemp .gt. 0) then
          isetvarlen = isetvarlen+2**(8*nbytes+7)
        else 
          return
        end if	
1     continue
      print*,'Problem in function isetvarlen'
      stop 1
      end
c
c
      subroutine writemidi(jobname,ljob)
      parameter(nm=12,mv=24576)
      common /all/ mult(nm,200),iv,nnl(nm),nv,ibar,
     *   ivxo(200),ipo(200),to(200),tno(200),tnote(200),eskz(nm,200),
     *   ipl(nm,200),ibm1(nm,8),ibm2(nm,8),nolev(nm,200),ibmcnt(nm),
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),nacc(nm,200),
     *   nib(nm,15),nn(nm),lenb0,lenb1,slfac,musicsize,stemmax,
     *   stemmin,stemlen,mtrnuml,mtrdenl,mtrnmp,mtrdnp,islur(nm,200),
     *   ifigdrop(125),iline,figbass,figcheck,firstgulp,irest(nm,200),
     *   iornq(nm,0:200),isdat1(202),isdat2(202),nsdat,isdat3(202),
     *   beamon(nm),isfig(200),sepsymq(nm),sq,ulq(nm,8)
      character*1 ulq,sepsymq,sq
      logical beamon,firstgulp,figbass,figcheck,isfig
      character*1 byteq(4),char,chax
      character*10 tempoq,instq
      character*24 jobname
      integer*2 mmidi
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
      common /comevent/ miditime,lasttime
      logical mmacrec,gottempo
      common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
     *       mmactime(20),nmidsec,msecstrt(0:nm,20),msecend(0:nm,20),
     *       mmacrec,gottempo
      character*79 inameq
      common /comtop / itopfacteur,ibotfacteur,interfacteur,isig0,
     *   isig,lastisig,fracindent,widthpt,height,idsig,
     *   lnam(nm),inameq(nm)
      logical rename
      common /comnvi/ nsperi(nm),nspern(nm),rename,iiorig(nm)
      integer*2 iinsiv(nm)
c
c  Write Header
c
      write(51,'(a,$)')'MThd'//char(0)//char(0)//char(0)//char(6)
     *  //char(0)//char(1)//char(0)//char(numchan+1)//char(0)//char(240)
cc
cc  Setup for tempos, in case none was given.  This may not be adequate
cc
c      if (imidi(numchan) .eq. 0) call midievent('t',96,0)
c
c  Write the "conductor" track, for keys, meter, and tempos
c  Get the number of bytes in the conductor event stream
c
      ndata = 1+imidi(numchan)-msecstrt(numchan,nmidsec)
      do 15 isec = 1 , nmidsec-1
        ndata = ndata+1+msecend(numchan,isec)-msecstrt(numchan,isec)
15    continue
      ib1 = (4+ljob+26+ndata+4)/256
      ib0 = 4+ljob+26+ndata+4-256*ib1
      write(51,'(a,$)')'MTrk'//char(0)//char(0)//char(ib1)//char(ib0)
c
c  Text header
c
     *  //char(0)//char(255)//char(1)//char(ljob+26)
      write(51,'(a,$)')jobname(1:ljob)
c
c  (separate writes are needed to defeat compiler BUG!!!)
c
      write(51,'(a,$)')'.mid, produced by PMX 2.19'
c
c  Conductor event data: Loop over sections. 
c
      do 16 isec = 1 , nmidsec
        if (isec .lt. nmidsec) then
          mend = msecend(numchan,isec)
        else
          mend = imidi(numchan)
        end if
        do 17 i = msecstrt(numchan,isec) , mend
          write(51,'(a,$)')char(mmidi(numchan,i))
17      continue
16    continue
c
c  And close out the time sig / tempo track.
c
      write(51,'(a,$)')char(0)//char(255)//char(2*16+15)//char(0)
c
c  Loop over track for each voice:  The following sets up iv.
c
      iv = nv
      if (twoline(nv)) then
        kv = 2
      else
        kv = 1
      end if
c
c  Count up staves(iv,nv) vs instruments.  Store instr# for iv in iinsiv(iv)
c
      nstaves = 0
      ivt = 0
      do 12 iinst = 1 , nm
        nstaves = nstaves+nsperi(iinst)
        do 13 ivtt = 1 , nsperi(iinst)
          ivt = ivt+1
          iinsiv(ivt) = iinst
13      continue
        if (nstaves .eq. nv) go to 14
12    continue
      print*,'Screwup!'
      stop 1
14    continue
c
      do 5 icm = 0 , numchan-1
c
c  Get the number of bytes in the data stream
c
        ndata = 1+imidi(icm)-msecstrt(icm,nmidsec)
        do 11 isec = 1 , nmidsec-1
          ndata = ndata+1+msecend(icm,isec)-msecstrt(icm,isec)
11      continue
c
c  Add 3 (for instrum) plus 4 (for closing) to byte count, 
c
        ndata = ndata+7
c
c  Add 4+lnam(iinsiv(iv)) if lnam>0 ,
c
        if (lnam(iinsiv(iv)).gt.0) ndata = ndata+4+lnam(iinsiv(iv))
c
c  Separate total byte counts into 4 bytes
c
        do 2 ibyte = 1 , 4
          if (ndata .gt. 0) then
            byteq(ibyte) = char(mod(ndata,256))
            ndata = ishft(ndata,-8)
          else
            byteq(ibyte) = char(0)
          end if
2       continue
c
c  Now write front stuff for this track
c
        write(51,'(a,$)')'MTrk'//byteq(4)//byteq(3)//byteq(2)//byteq(1)
     *    //char(0)//char(12*16+icm)//char(midinst(iv))
        if (lnam(iinsiv(iv)) .gt. 0) then
c
c  Add instrument name as sequence name
c
          write(51,'(a,$)')char(0)//char(255)//char(3)
     *        //char(lnam(iinsiv(iv)))
          write(51,'(a,$)')
     *        inameq(iinsiv(iv))(1:lnam(iinsiv(iv)))
        end if
        write(tempoq,'(i2)')icm
        write(instq,'(i3)')midinst(iv)
        call printl('MIDI instrument '//tempoq(1:2)//' is '//instq(1:3))
c
c  Notes: Loop over sections. 
c
        do 9 isec = 1 , nmidsec
          if (isec .lt. nmidsec) then
            mend = msecend(icm,isec)
          else
            mend = imidi(icm)
          end if
          do 10 i = msecstrt(icm,isec) , mend
            write(51,'(a,$)')char(mmidi(icm,i))
10        continue
9       continue
c
c  Closing 4 bytes
c
        write(51,'(a,$)')chax(0)//char(255)//char(2*16+15)//char(0)
        if (kv .eq. 2) then
          kv = 1
        else if (iv .eq. 1) then
          go to 5
        else
          iv = iv-1
          if (twoline(iv)) kv=2 
        end if
5     continue
      write(*,'(1x,a12,12i6)')'Bytes used:',(imidi(icm),icm=0,numchan)
      write(15,'(1x,a12,12i6)')'Bytes used:',(imidi(icm),icm=0,numchan)
      close(51)
      return
      end
      subroutine getmidi(nv,lineq,iccount,ibarcnt,ibaroff,nbars,lenbar,
     *                    mtrdenl,first)
c
c  Use this from both pmxa and pmxb to input and check midi data. "first" tells
c  whether pmxa or pmxb.  If .not.first, then tempo and pause commands cause
c  things to be written immediately into the midi storage buffers.
c
      parameter (nm=12,mv=24576)
      common /comevent/ miditime,lasttime
      logical mmacrec,gottempo
      common /commmac/ mmacstrt(0:nm,20),mmacend(0:nm,20),immac,
     *       mmactime(20),nmidsec,msecstrt(0:nm,20),msecend(0:nm,20),
     *       mmacrec,gottempo
c
c  immac(i) is the index of i-th macro, i=1,nmac.  Also make a list containing
c   nmidsec  section starts and stops based on PLAYING macros (not recording).
c 
      integer*2 mmidi,midinum(26)
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
      character*1 durq
      character*2 instq
      character*128 lineq
      logical first
      common /comdiag/ n69(0:nm)
c
c      Instrument codes
c
      data midinum   
     *    / 1, 5, 7, 13,20,25,33,41,42,43,44,57,58,59,61,65,66,67,
c         XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbXtuXfrXsoXalXteX
c
     *      68,69,71,72,74,75, 8,55 /
c           bsXobXbaXclXflXreXctXvo
c
1     call getchar(lineq,iccount,durq)
      if (durq .eq. 't') then
c
c  Tempo in beats ber minute
c
        call getchar(lineq,iccount,durq)
        if (index('0123456789',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'Expected an integer here for the pause!')
          stop 1
        else if (mmacrec) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'Cannot change MIDI tempo while recording a MidiMacro!')
          stop 1
        end if
        call readnum(lineq,iccount,durq,qpm)
        iccount = iccount-1
        if (.not.first) then
          call midievent('t',nint(qpm),0)
          gottempo = .true.
        end if
        go to 1
      else if (durq .eq. 'p') then
c
c  Insert a pause.  pausemid = pause in 1/4's
c
        call getchar(lineq,iccount,durq)
        if (index('0123456789.',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'Expected a number here for the pause!')
          stop 1
        end if
        call readnum(lineq,iccount,durq,pausemid)
        iccount = iccount-1
        if (.not.first) then
c
c  Compute a meter for the pause.  This is only to keep MidiNotate on track.
c  Round pause to nearest 16th.  Let denominator always be 16.
c
          numb16 = nint(pausemid*4)
          call midievent('m',numb16,16)
c
c  Put in pausemid beats of rest 
c
          do 3 icm = 0 , numchan-1
            call addmidi(icm,0,0,0,4.*numb16,.true.,.false.)
3         continue
          miditime = miditime+nint(240*pausemid)
c
c  Restore meter
c
          call midievent('m',mtrdenl*lenbar/64,mtrdenl)
        end if
        go to 1
      else if (durq .eq. 'i') then
c
c  Instrument numbers or letters.  Expect nv of them.
c
        do 2 ivx = 1 , nv
          call getchar(lineq,iccount,durq)
          if (ichar(durq) .gt. 96) then
c
c  It's a lowercase letter.  Get another, find corr. instrument #.
c
            instq(1:1) = durq
            call getchar(lineq,iccount,durq)
            instq = instq(1:1)//durq
            iname = index('XXpiXrhXhaXmaXorXguXabXvlXvaXvcXcbXtrXtbX'//
     *                'tuXfrXsoXalXteXbsXobXbaXclXflXreXctXvo',instq)/3
            if (iname .eq. 0) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'Unrecognized 2-letter midi instrument name!')
              stop 1
            end if
            midinst(ivx) = midinum(iname)-1
          else
c
c  Expect a number, followed by ":" if that is followed by another number.
c  I.e., if after call to readnum, durq is not ":", it must be either blank
c  or next instrument letter.
c
            if (index('123456789',durq) .eq. 0) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *                 'Expected a midi instrument number here!')
              stop 1
            end if
            call readnum(lineq,iccount,durq,fnum)
            midinst(ivx) = nint(fnum)-1
            if (midinst(ivx).lt.0 .or. midinst(ivx).gt.255) then
              call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *           'Midi instrument number must be in range 1-128!')
              stop 1
            end if
            if (durq .ne. ':') iccount = iccount-1
          end if
2       continue
        go to 1
      else if (durq .eq. 'g') then
        call getchar(lineq,iccount,durq)
        if (index('0123456789',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'Expected an integer here for the midi gap!')
          stop 1
        end if
        call readnum(lineq,iccount,durq,fnum)
        mgap = nint(fnum)
        iccount = iccount-1
        go to 1
      else if (durq .eq. 'M') then
c
c  MidiMacros
c
        call getchar(lineq,iccount,durq)
        if (durq .eq. 'R') then
c
c  Start recording
c
          if (mmacrec) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'You tried to record a MidiMacro while already recording!')
            stop 1
          end if
          mmacrec = .true.
          call getchar(lineq,iccount,durq)
          if (index('123456789',durq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *        'Expected MidiMacro ID number here!')
            stop 1
          end if
          call readnum(lineq,iccount,durq,fnum)
          iccount = iccount-1
          if (.not.first) then
            immac = nint(fnum)
            if (immac .gt. 20) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'MidiMacro ID cannot exceed 20!')
              stop 1
            end if
c
c  Save the start time
c
            mmactime(immac) = miditime
            do 4 icm = 0 , numchan
              if (icm .lt. numchan) then
                if (restpend(icm)) then
c
c  Adjust if there's a rest at end of prior section.  Insert dummy turnoff.
c    (This causes two turn-offs in a row, which testmidi sees as an error).
c
c  Before:    section1  ------rest-------  section2(to be recorded)
c  After:     section1  rest1  now  rest2  section2(recorded)
c
                  call addmidi(icm,30,0,0,trest(icm),.false.,.true.)
                  trest(icm) = 0
                  restpend(icm) = .false.
                end if
              else
                if (miditime .gt. lasttime) then
c
c  Insert a dummy turnoff in conductor track
c
                  call addmidi(icm,30,0,0,(miditime-lasttime)/15.,
     *                         .false.,.true.)
                  lasttime = miditime
                end if
              end if
              mmacstrt(icm,immac) = imidi(icm)+1
4           continue
          end if
          go to 1
        else if (index('123456789P',durq) .eq. 0) then
c
c  End recording; close the open macro.  Get immac from common.
c
          if (.not.mmacrec) then
            call errmsg(lineq,iccount-1,ibarcnt-ibaroff+nbars+1,
     *       'You tried to end a MidiMacro before starting one!')
            stop 1
          end if
          mmacrec = .false.
          iccount = iccount-1
          if (.not.first) then
c
c  Save the macro duration
c
            mmactime(immac) = miditime-mmactime(immac)
            do 5 icm = 0 , numchan
              if (icm .lt. numchan) then
                if (restpend(icm)) then
                  call addmidi(icm,30,0,0,trest(icm),.false.,.true.)
                  trest(icm) = 0
                  restpend(icm) = .false.
                end if
              else
                if (miditime .gt. lasttime) then
c
c  Insert a dummy turnoff in conductor track if needed.
c
                  call addmidi(icm,30,0,0,(miditime-lasttime)/15.,
     *                         .false.,.true.)
                  lasttime = miditime
                end if
              end if
              mmacend(icm,immac) = imidi(icm)
5           continue
          end if
          if (durq .ne. ' ')go to 1
        else if (durq .eq. 'P') then
c
c  Play Back a Macro
c
          call getchar(lineq,iccount,durq)
          if (index('123456789',durq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *        'Expected MidiMacro ID number here!')
            stop 1
          end if
          if (mmacrec) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'You tried to play a MidiMacro before ending recording!')
            stop 1
          end if
          call readnum(lineq,iccount,durq,fnum)
          iccount = iccount-1
          if (.not.first) then
            immac = nint(fnum)
            if (mmactime(immac) .eq. 0) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'Cannot play a MIDI macro before recording it!')
              stop 1
            end if
            do 6 icm = 0 , numchan
              if (icm .lt. numchan) then
                if (restpend(icm)) then
                  call addmidi(icm,30,0,0,trest(icm),.false.,.true.)
                  trest(icm) = 0.
                  restpend(icm) = .false.
                end if
              else
                if (miditime .gt. lasttime) then
c
c  Insert a dummy turnoff in conductor track
c
                  call addmidi(icm,30,0,0,(miditime-lasttime)/15.,
     *                         .false.,.true.)
                end if
              end if
              msecend(icm,nmidsec) = imidi(icm)
              msecstrt(icm,nmidsec+1) = mmacstrt(icm,immac)
              msecend(icm,nmidsec+1) = mmacend(icm,immac)
              msecstrt(icm,nmidsec+2) = imidi(icm)+1
6           continue
            nmidsec = nmidsec+2
c
c  Update running time
c
            miditime = miditime+mmactime(immac) 
            lasttime = miditime
          end if
          go to 1 
        else
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'Illegal character in MidiMacro sub-command!')
          stop 1
        end if
      else if (durq .ne. ' ') then
        call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'Illegal character in MIDI input data!')
        stop 1
      end if
      if (.not.gottempo .and. .not.first) then
c
c  If no tempo is set on first call on the pmxb pass, then set it
c
        call midievent('t',96,0)
        gottempo = .true.
      end if
      return
      end
      subroutine chkimidi(icm)
      parameter (nm=12,mv=24576)
      integer*2 mmidi
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
      if (imidi(icm) .ge. mv) then
        print*
        print*,'Midi file is too long! It will be corrupted or worse'
        write(*,'(a6,2x,4i8)')
     *        'imidi:',imidi(0),imidi(1),imidi(2),imidi(3)
      end if
      return
      end
      subroutine midievent(typeq,in1,in2)
c
c  We now store "conductor" events in mmidi(numchan,.), and count bytes
c    with imidi(numchan)
c
      parameter (nm=12,mv=24576)
      integer*2 mmidi
      logical restpend,relacc,notmain,twoline,ismidi,crdacc
      common /commidi/ imidi(0:nm),trest(0:nm),mcpitch(10),mgap,
     *       iacclo(0:nm,6),iacchi(0:nm,6),midinst(nm),
     *       nmidcrd,midchan(nm,2),numchan,naccim(0:nm),
     *       laccim(0:nm,10),jaccim(0:nm,10),crdacc,notmain,
     *       restpend(0:nm),relacc,twoline(nm),ismidi,mmidi(0:nm,mv)
      common /comevent/ miditime,lasttime
      character*1 typeq
      idur = isetvarlen(miditime-lasttime,nbytes)
      imidi(numchan) = imidi(numchan)+nbytes+1
      do 1 i = 1 , nbytes
        mmidi(numchan,imidi(numchan)-i) =  mod(idur,256)
        idur = ishft(idur,-8)
1     continue
      mmidi(numchan,imidi(numchan)) = 255
      if (typeq .eq. 't') then
c
c  Tempo event.  in1 = quarters per minute (integer)
c
        mmidi(numchan,imidi(numchan)+1) = 5*16+1
        mmidi(numchan,imidi(numchan)+2) = 3
        misperq = nint(60000000./in1)
        do 2 i = 1 , 3
          mmidi(numchan,imidi(numchan)+6-i) =  mod(misperq,256)
          misperq = ishft(misperq,-8)
2       continue
        imidi(numchan) = imidi(numchan)+5
      else if (typeq .eq. 'm') then
c
c  Meter event.  in1=numerator, in2=denom (power of 2)
c
        mmidi(numchan,imidi(numchan)+1) = 5*16+8
        mmidi(numchan,imidi(numchan)+2) = 4
        mmidi(numchan,imidi(numchan)+3) = in1
        if (in2 .gt. 0) then
          mmidi(numchan,imidi(numchan)+4) = log2(in2)
        else
          mmidi(numchan,imidi(numchan)+4) = 0
        end if
        mmidi(numchan,imidi(numchan)+5) = 24
        mmidi(numchan,imidi(numchan)+6) = 8
        imidi(numchan) = imidi(numchan)+6
      else if (typeq .eq. 'k') then
c
c  Keychange event.  in1 = isig
c
        mmidi(numchan,imidi(numchan)+1) = 5*16+9
        mmidi(numchan,imidi(numchan)+2) = 2
        mmidi(numchan,imidi(numchan)+3) = mod(256+in1,256)
        mmidi(numchan,imidi(numchan)+4) = 0
        imidi(numchan) = imidi(numchan)+4
      else
        print*,'Program flameout in midievent'
        stop 1
      end if
      lasttime = miditime
      return
      end
c      integer*4 function longi(ishort)
c      integer*2 ishort
c      longi = ishort
c      return
c      end
      function iashft(nacc)
      integer*4 ias(6)
      data ias /-1,1,0,0,-2,2/
      iashft = ias(nacc)
      return
      end