cccccccccccccccccccccccccccccccccccccccccccccccc
cc                                            cc
cc pmxa.for  Version 1.1 - 3 February 1997    cc
cc                                            cc
cc A production of Dr. Don's PC and           cc
cc Harpsichord Emporium (dsimons@logicon.com) cc
cc                                            cc
cc This is noware: No fee, no guarantee.      cc
cc                                            cc
cccccccccccccccccccccccccccccccccccccccccccccccc
      parameter (nm=7)
      logical loop,usefig
      integer nn(nm),list(4,200),ipl(nm,200),nodur(nm,200),
     *        nnl(nm),itsofar(nm),nib(nm,15),lastbar(0:75),nbarss(75)
      common /comnotes/ nnodur,wminnh(300),nnpd(2000),durb(2000),
     *     nptr(301),ibarcnt,ieminb(300),iemaxb(300),mbrest,ibarmbr,
     *     ibaroff
      common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:20),
     *      isysflb(0:20),npages,nfpb,ipagfpb(0:10),isysfpb(0:10),
     *      isig,usefig
      real*4 elsk(300),celsk(0:300),elss(75)
      character*128 lineq
      character*24 basenameq,inameq(nm)
      logical rest(nm,200),firstline,fbon,isvolt
      common /comget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt
      logical lastchar,newmeter,newmb(300),issegno,bottreb,isheadr
      common /all/ iv,list,nnl,nv,ibar,ipl,mtrnuml,
     *   nodur,jn,lenbar,iccount,nbars,itsofar,nib,nn,
     *   rest,lenbr0,lenbr1,firstline,newmeter
      common /linecom/ elskb
      common /cblock/ 
     *      etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
     *      xilbn,xilbtc,xilhdr,xilfig,a,b,inbothd,inhnoh  
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx,fbar
      lastchar = .false.
      do 42 ibarcnt = 1 , 300
        wminnh(ibarcnt) = -1.
42    continue
      print*,'Please type a basename (<9 characters, no dots): '
      read(*,'(a)')basenameq  
      idot = index(basenameq,'.')
      if (idot .ne. 0) then
        basenameq = basenameq(1:idot-1)
      end if
      lbase = index(basenameq,' ')-1
      data wtimesig,wclef,wkeysig, a20,whead20 , abig20
     *   / 0.72  , 0.8 ,  0.25, 0.3 , 0.3 ,     0.38  /
      open(10,file=basenameq(1:lbase)//'.pmx')
      read(10,*)nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0,isig,
     *          npages,nsyst,musicsize,fracindent
      if (npages .gt. nsyst) then
        print*,'npages > nsyst in input.  Please fix the input.'
        stop
      end if 
c
c  fbar = afterruleskip/elemskip
c  apt = width of small accidental + space in points (= 6 at 20pt)
c  abigpt = width of big accidental + space in points (= 7.6 at 20pt)
c
      fbar = 1.
c     fbar = 1.333
c     if (musicsize.ne.20) fbar = 1.20 
      apt = a20*musicsize
      abigpt = abig20*musicsize
      wheadpt = whead20*musicsize
c
c  Need the following stuff to set the line counter
c
      read(10,'(a)')inameq(1)
      rewind(10)
      do 25 nline = 1 , 100
        read(10,'(a)')lineq
        if (lineq .eq. inameq(1)) go to 27
25    continue
      print*,'Problem in first few lines of input file'
      stop
27    continue
      do 6 iinst = 2 , noinst
        read(10,'(a)')inameq(iinst)
6     continue
      read(10,'(a128)')lineq
      if (index(lineq,' ') .ne. nv+1) then
        print*,
     *   'I found something wrong where the clefs are supposed to be.'
        stop
      end if
c
c Must check if clef for voice 1 is treble, since it affects vertical spacing
c
      bottreb = lineq(1:1).eq.'t'
      read(10,'(a128)')lineq
      lpath = index(lineq,' ')-1
      if (lineq(lpath:lpath).ne.'/'.and.
     *    lineq(lpath:lpath).ne.char(92)) then
        print*,
     *   'Last character of pathname is neither / nor '//char(92)//' .'
        print*,'Do you want to continue? ("y" to continue)'
        read(*,'(a)')lineq
        if (lineq(1:1).ne.'y' .and. lineq(1:1).ne.'Y') stop
      end if
      nline = nline+noinst+1
      ifig = 0
      usefig = .true.
      lenbeat = ifnodur(mtrdenl,'x')
      lenmult = 1
      if (mtrdenl .eq. 2) then
        lenbeat = 16
        lenmult = 2
      end if
      lenbr1 = lenmult*mtrnuml*lenbeat
      lenbr0 = lenmult*xmtrnum0*lenbeat+.1
      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
      nflb = 0
      nfpb = 0
      ipagfpb(0) = 1
      isysfpb(0) = 1
      ibarflb(0) = 1
      isysflb(0) = 1
c
c  Initialize for loop over lines
c
      firstline = .true.
      newmeter = .false.
      ihead = 0 
30    loop = .true.
      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.
      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 getnote(loop,ifig) 
        if (lastchar) go to 20
        go to 2
      end if
      do 10 ibar = 1 , nbars
        ibarcnt = ibarcnt+1
        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
          print*,'Now processing bar #',ibarcnt-ibaroff
        else
          write(*,'(a19,i4,a1,i4)')' Multibar rest, bars',
     *       ibarcnt-ibaroff,'-',ibarcnt-ibaroff+mbrest-1
          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
10    continue
      firstline = .false.
      newmeter = .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
        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
      nflb = nflb+1
      ibarflb(nflb) = ibarcnt+1
      isysflb(nflb) = nsyst+1
      heightil = ptheight*4./musicsize
c
c  Set up dummy forced page after last real one 
c
      nfpb = nfpb+1
      ipagfpb(nfpb) = npages+1
      isysfpb(nfpb) = nsyst+1 
      open(12,file='pmxtex.dat')
      write(12,'(a)')basenameq(1:lbase)
      write(12,*)lbase
      write(12,'(8f10.5/f10.5,3i5)')fbar,apt,abigpt,wheadpt,etait,
     *     etatc,etacs1,etatop,etabot,inbothd,inhnoh,isig
      write(12,*)npages,widthpt,ptheight,nsyst
      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
c       write(12,*)npages,widthpt,ptheight,nsyst
        do 7 ipage = 1 , npages
          nsystp = nomnsystp
          if (ipage .le. nshort) nsystp = nsystp-1
          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/musicsize
              xilfrac = xilfrac+etait
            end if
            if (iand(ihead,2) .eq. 2) then
              xiltxt = xiltxt+hgtti*4/musicsize
              xilfrac = xilfrac+etatc
            end if
            if (iand(ihead,4) .eq. 4) then
              xiltxt = xiltxt+hgtco*4/musicsize
              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 = nsystp*(nv-1)
          xN = heightil - xiltxt - 4*nsystp*nv - (nsystp-1)*xilbn 
          if (bottreb) xN = xN-(nsystp-1)*xilbtc
          if (ihead.eq.0 .and. isheadr) then 
            xN = xN - xilhdr 
            isheadr = .false.
          end if
          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 = N/(D + omega * C) = glueil,   (1)
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  D = omega-indep factors for scalable height = nsy-1 (intersystem glue)
c      + etatop + etabot + etatxt + 
c  C*omega = nsy*(nv-1)*omega (\interstaff part)
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
        write(12,*)nsystp,max(0.,etatop*glueil),omegaG+4
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
c
c  Return nsyst to it's total value
c
      nsyst = isysfpb(nfpb)-1
      do 22 isyst = 1 , nsyst
        if (isyst .eq. isysflb(iflb)) iflb = iflb+1
        ibarb4 = lastbar(isyst-1)
        if (isyst .eq. 1) then
c         elsstarg = celsk(ibarcnt)/(nsyst-fracindent)*(1-fracindent)
          elssold = celsk(ibarcnt)/(nsyst-fracindent)*(1-fracindent)
          elsstarg = celsk(ibarflb(1)-1)/(isysflb(1)-1-fracindent)
     *                 *(1-fracindent)
          celskb4 = 0.
        else
          celskb4 = celsk(ibarb4)
c         elsstarg = (celsk(ibarcnt)-celskb4)/(nsyst-isyst+1)
          elssold = (celsk(ibarcnt)-celskb4)/(nsyst-isyst+1)
          elsstarg = (celsk(ibarflb(iflb)-1)-celskb4)
     *                           /(isysflb(iflb)-isyst)
        end if
        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
c
c  elss is the # of elemskip in the system from notes, not ruleskips or ask's
c
        elss(isyst) = celsk(ibar)-celskb4
        write(12,'(i5)')lastbar(isyst-1)+1
        fsyst = wclef+iabs(isig)*wkeysig+2./musicsize
c
c  Add extra fixed space for double bar
c
        if (isyst .eq. nsyst) fsyst = fsyst+4.5/musicsize
c
c  Add extra fixed space for initial time signature
c
        if (isyst .eq. 1) fsyst = fsyst+wtimesig
c
c  Add extra fixed space for time signature changes
c
        do 26 ibars = ibarb4+1 , lastbar(isyst)
          if (newmb(ibars)) fsyst = fsyst+wtimesig
26      continue
        wdpt = widthpt
        if (isyst .eq. 1) wdpt = widthpt*(1-fracindent)
        wsyspt = wdpt-fsyst*musicsize-0.4*nbarss(isyst)
c
c  Checks for min spacing
c  Get range of NOtes def'ns required, also min allowable space
c
        iemin = 1000
        iemax = 0
        do 45 ibar = ibar1 , ibar1+nbarss(isyst)-1
          iemin = min(iemin,ieminb(ibar))
          iemax = max(iemax,iemaxb(ibar))
          if (wminnh(ibar).ge.0.) wmins = wminnh(ibar)
45      continue
        if (wmins .lt. 0) wmins = 0.3 
        wminpt = (1+wmins)*0.3*musicsize
c
c  Find min,max actual duration for this system & # of notes
c
        dtmin = 1000.
        dtmax = 0.
        nns = 0
        do 43 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1
          dtmin = min(dtmin,durb(iptr))
          dtmax = max(dtmax,durb(iptr))
          nns = nns + nnpd(iptr)
43      continue
        elmin0 = wsyspt*feon(dtmin)/(elss(isyst)+fbar*nbarss(isyst))
        if (elmin0 .ge. wminpt) then
          sumelsk = elss(isyst)
          eonk = 0.
          ewmxk = 1.
        else
          elmin1 = wsyspt/(fbar*nbarss(isyst)/feon(dtmax)+nns)
          if (elmin1 .le. wminpt) then
            print*,'In system #',isyst,' cannot meet min. space rqmt'
            eonk = 0.9
          else
            eonk = min(.9,(wminpt-elmin0)/(elmin1-elmin0))
          end if
          ewmxk = feon(dtmax)**eonk
c
c  Recompute poenom!
c
          sumelsk = 0
          do 44 iptr = nptr(ibar1) , nptr(ibar1+nbarss(isyst))-1
            sumelsk = sumelsk
     *       + nnpd(iptr)*feon(durb(iptr))**(1-eonk)*ewmxk
44        continue
        end if
        poenom = wsyspt/(sumelsk+fbar*nbarss(isyst))
c       write(12,'(i5,1p5e12.3,2i5)') nbarss(isyst),sumelsk,poenom,
c    *             fsyst,eonk,ewmxk,iemin,iemax
        write(12,'(1pe12.5/i5,4e12.3,2i5)') poenom,nbarss(isyst),
     *       sumelsk,fsyst,eonk,ewmxk,iemin,iemax
        ibar1 = ibar1+nbarss(isyst)
22    continue
      close(12)
      open(13,file='pmxtex.fig')
      write(13,'(i5)')ifig
      close(13)
      print*,'Done with first pass.  Now run pmxb.'
      end
      subroutine getnote(loop,ifig)
      parameter (nm=7)
      common /all/ iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),mtrnuml,
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),
     *   rest(nm,200),lenbr0,lenbr1,firstline,newmeter
      common /comnotes/ nnodur,wminnh(300),nnpd(2000),durb(2000),
     *     nptr(301),ibarcnt,ieminb(300),iemaxb(300),mbrest,ibarmbr,
     *     ibaroff
      common /comget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt
      common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:20),
     *      isysflb(0:20),npages,nfpb,ipagfpb(0:10),isysfpb(0:10),
     *      isig,usefig
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx,fbar
      logical lastchar,firstline,rest,loop,newmeter,fbon,issegno,
     *        isheadr,fulbrp,usefig,isvolt
      character*128 lineq
      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 <80 char, end with backslash !'/
1     call getchar(lineq,iccount,charq)
      if (charq .ne. ' ') charlq = charq
      if (lastchar) then
        if (charlq .ne. '/') then
          print*,'Last non-blank character is not "/"'
          stop
        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.  Increase note count, then loop 'til blank
c
        nnl(ivx) = nnl(ivx)+1
        dotq = 'x'
        numnum = 0
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,nnl(ivx)-1) .and.
     *    nodur(ivx,nnl(ivx)-1) .eq. lenbar
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
            numnum = 2
            go to 2
          else
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             '>2 digits in note symbol!')
            stop
          end if
        else if (durq.eq.'d') then
          dotq = durq
          go to 2
        else if (index('+-',durq) .gt. 0) then
          if (charq .ne. 'r') go to 2
          call getchar(lineq,iccount,durq)
          call readnum(lineq,iccount,durq,dum)
          if (durq .ne. ' ') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *        '+/-(number) in rest symbol must be followed by blank!')
            stop
          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,
     *             'You entered "p"; I expected "rp"!')
            stop
          else if (lineq(iccount+1:iccount+1).ne.' ') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'You entered "rp" followed by non-blank!')
            stop
          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
          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 getchar(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
          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
          else if (index(' n',durq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Only legal characters here are " " or "n"!')
            stop
          end if
          ntup = int(fnum+.1)
          do 6 itup = 2 , ntup
            nodur(ivx,nnl(ivx)) = 0
            nnl(ivx) = nnl(ivx)+1
110         call getchar(lineq,iccount,durq)
            if (durq.eq.' ') then
              go to 110
            else if (durq.eq.'s') then
15            call getchar(lineq,iccount,dumq) 
              if (index('udl',dumq) .gt. 0) then
                go to 15
              else if (index('+-',dumq) .gt. 0) then
                iccount = iccount+1
                call readnum(lineq,iccount,durq,fnum)
                if (int(fnum+.5) .gt. 15) then
                  call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'Magnitude of slur height adjustment cannot exceed 15!')
                  stop
                end if
                iccount = iccount-1
                go to 15
              else if (dumq .ne. ' ') then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *                   'Illegal character in slur symbol!')
                stop
              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
              else if (durq.eq.'x') then 
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *            'No floating figures in xtuplets!')
                stop
              end if
              if (usefig) ifig = 1
26            call getchar(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
              end if
              go to 110
            else if (durq .eq. char(92)) then
              call chklit(lineq,iccount,literr)
              if (literr .gt. 0) then
                call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               literq(literr))
                stop
              end if
              go to 110
            end if
            if (index('abcdefg',durq) .eq. 0) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               'In xtup, this character should be "a-g"!')
              stop
            end if
7           call getchar(lineq,iccount,durq)
            if (index('+-sfn',durq) .gt. 0) go to 7 
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
          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
          else if (ibarmbr .gt. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Only one multibar rest allowed per block!')
            stop
          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 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
          if (durq .ne. ' ') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Illegal character after "rm"!')
            stop
          end if
        else if (durq .ne. ' ') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Illegal character!')
          stop
        end if
        if (charq .eq. 'r') rest(ivx,nnl(ivx)) = .true.
        if (ibarmbr.ne.nbars+1 .and. .not.fulbrp) then
          nodur(ivx,nnl(ivx)) = ifnodur(nnodur,dotq)
        else if (fulbrp) then
          nodur(ivx,nnl(ivx)) = lenbar
          fulbrp = .false.
        end if
c
c  If inside forced beam, check if note is beamable 
c
        if (fbon.and.(rest(ivx,nnl(ivx)).or.nodur(ivx,nnl(ivx)).ge.16))
     *       then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Unbeamable thing in forced beam!')
          stop
        end if
        itsofar(ivx) = itsofar(ivx)+nodur(ivx,nnl(ivx))
        if (mod(itsofar(ivx),lenbar) .eq. 0) then
          nbars = nbars+1
          if (nbars .gt. 15) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'Cannot have more than 15 bars in an input block!')
            stop
          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
            end if
            lenbar = lenbr1
            itsofar(ivx) = 0
          end if
        end if 
      else if (charq .eq. 'z') then
        call getchar(lineq,iccount,charq)
25      call getchar(lineq,iccount,durq)
        if (index('nfs+-12345678dre',durq) .gt. 0) go to 25
        if (durq .ne. ' ') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      'Illegal character in chord note!')
          stop
        end if
      else if (charq .eq. 'G') then
        ngr = 1
9       call getchar(lineq,iccount,charq)
        if (index('123456789',charq) .gt. 0) then
          call readnum(lineq,iccount,durq,fnum)
          ngr = int(fnum+.1)
          iccount = iccount-1
          go to 9
        else if (index('ulxs',charq) .gt. 0) then
          go to 9
        else if (charq .eq. 'm') then
          call getchar(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
          end if
          go to 9
        end if
c
c  At this point, charq is first note name in rest
c
        do 19 igr = 1 , ngr
          numnum = 0
          if (igr .gt. 1) call getchar(lineq,iccount,charq)
          if (index('abcdefg',charq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'In a grace, character should be "a"-"g"!')
            stop
          end if
18        call getchar(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
              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
          end if
19      continue
      else if (charq .eq. char(92)) then
        call chklit(lineq,iccount,literr)
        if (literr .gt. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               literq(literr))
          stop
        end if
      else if (charq .eq. 'o') then
c
c  "o" symbol must come AFTER the affected note
c
        call getchar(lineq,iccount,dumq) 
        if (index('stmgx+Tupf)',dumq) .eq. 0 ) then 
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Illegal ornament!')
          stop
        end if
        if (dumq .eq. 'g') then
          if (issegno) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Sorry, only one "segno" per input block!')
            stop
          else if (ivx .ne. 1) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'segno can only be in voice 1!')
            stop
          end if
          issegno = .true.
12        call getchar(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
          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 getchar(lineq,iccount,dumq) 
          if (dumq .ne. ' ') go to 22
        end if
      else if (charq .eq. 's' .or. charq .eq. 't') then 
8       call getchar(lineq,iccount,dumq) 
        if (index('udl',dumq) .gt. 0) then
          go to 8
        else if (index('+-',dumq) .gt. 0) then
          if (charq .eq. 't') then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *     '"+|-" for slur height only allowed in "s"-slurs!') 
            stop
          end if
          iccount = iccount+1
          call readnum(lineq,iccount,durq,fnum)
          if (int(fnum+.5) .gt. 15) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *       'Magnitude of slur height adjustment cannot exceed 15!')
            stop
          end if
          iccount = iccount-1
          go to 8
        else if (dumq .ne. ' ') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Illegal character in slur symbol!')
          stop
        end if
      else if ((ichar(charq).ge.48.and.ichar(charq).le.57) .or.
     *    index('#-nx',charq) .gt. 0) then
c
c  We have a figure.  Must come AFTER the note it goes under
c
        if (charq.eq.'x' .and.lineq(iccount+1:iccount+1).eq.' ') then
          iccount = iccount+1
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Cannot have a blank after "x" here!')
          stop
        end if
        if (usefig) ifig = 1
5       call getchar(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
        end if
        fbon = .true.
17      call getchar(lineq,iccount,charq)
        if (index('ul',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 .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
        end if
      else if (charq .eq. ']') then
        call getchar(lineq,iccount,charq)
        if (charq .eq. ' ') then
          if (fbon) then
            fbon = .false.
          else
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Forced beam stop with no corresponding start!')
            stop
          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
          end if
        else
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         '"]" must be followed by blank or "["!')
          stop
        end if
      else if (index('lhw',charq) .gt. 0) then 
        isheadr = charq .eq. 'h'
        call getchar(lineq,iccount,durq)
        if (durq .eq. ' ') then
          if (charq .ne. 'w') then
c
c  Header or lower string. 
c
            if (iccount .ne. 2) then
              call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *               '"h" or "l" must be first character in line!')
              stop
            end if
c
c  just read past it.
c
            read(10,'(a)')charq
            nline = nline+1
            iccount = 128
          else
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *             'Symbol "w" (width) must be followed by a digit!')
            stop
          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
          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
          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!')
          stop
        end if
        newmeter = .true.
        call readmeter(lineq,iccount,mtrnuml,mtrdenl)
        call readmeter(lineq,iccount,mtrnmp,mtrdnp)
c
c  Read past printed time signature; not used in pmxa.
c
        lenbeat = ifnodur(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 getchar(lineq,iccount,durq)
        if (.not.(index('tsmanrb',durq).gt.0 .or. 
     *      (ichar(durq).ge.48 .and. ichar(durq).le.54))) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Must have t,s,m,a,n,r,b or 1-6 after C!')
          stop
        end if
      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
        end if
10      call getchar(lineq,iccount,durq)
        if (index('lrdD',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
        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
        else if (isvolt) then
          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'
          pause 'Hit return to continue.'
        end if
        isvolt = .true.
11      call getchar(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
        end if
16      call getchar(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 .ne. ' ') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Only "l", "r", or digit allowed after "P"!')
          stop
        end if
      else if (charq .eq. 'W') then
        call getchar(lineq,iccount,durq)
        if (durq .ne. '.') then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Next char after " W" must be "."!')
          stop
        end if
        call getchar(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
        end if
      else if (charq .eq. 'T') then
c
c  Titles
c
        call getchar(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
        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
        read(10,'(a)')charq
        nline = nline+1
        iccount = 128
      else if (charq .eq. 'A') then
27      call getchar(lineq,iccount,durq)
        if (index('rbs',durq) .gt. 0) then
          go to 27
        else if (durq .eq. 'a') then
          call getchar(lineq,iccount,durq)
          call readnum(lineq,iccount,durq,fbar)
          iccount = iccount-1
          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"!')
          stop
        end if
      else if (charq .eq. 'K') then
        call getchar(lineq,iccount,durq)
        if (index('+-',durq) .eq. 0) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      '"K" (transpose) must be followed by "+,-"!')
          stop
        end if
        iccount = iccount+1
        call readnum(lineq,iccount,durq,fnum)
        if (durq .eq. '+') then
          isign = 1
        else if (durq .eq. '-') then
          isign = -1
        else
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *      '1st number after "K" must be followed by "+,-"!')
          stop 
        end if
        iccount = iccount+1
        call readnum(lineq,iccount,durq,fnum)
        isig = isign*int(fnum+.1)
      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
        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
        end if
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!')
          stop
        else if (ivx.gt.1 .and. itsofar(ivx).ne.itsofar(1)) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Block duration not equal to voice 1!')
          stop
        end if
        call getchar(lineq,iccount,durq)
        if (durq .eq. ' ' .and. iv.eq.nv) then
c
c  End of input block
c
          loop = .false.
        else 
c
c  Start a new voice
c
          if (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
            nvmx(iv) = 2
            ivmx(iv,2) = ivx
            itsofar(ivx) = 0
            nnl(ivx) = 0
            do 24 j = 1 , 200
              rest(ivx,j) = .false.
24          continue
          end if
        end if
      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
        end if
        call getchar(lineq,iccount,durq)
        call readnum(lineq,iccount,durq,fnsyst)
        nsyst = int(fnsyst+.1)
        if (durq .eq. 'P') then
c
c  New npages for parts.  Assuming <10.
c
          call getchar(lineq,iccount,durq)
          if (index('123456789',durq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Symbol after "P" must be a digit!')
            stop
          end if
          npages = ichar(durq)-48
        end if
      else if (charq .eq. 'L') then
        nflb = nflb+1
        ibarflb(nflb) = ibarcnt+nbars+1
        call getchar(lineq,iccount,durq)
        call readnum(lineq,iccount,durq,sysflb)
        isysflb(nflb) = int(sysflb+.1)
        if (npages .eq. 0) then 
          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
        else if (isysflb(nflb) .gt. nsyst) then
          call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *           'Forced line break at non-existant system!')
          stop
        end if
        if (durq .eq. 'P') then
c
c  Forced page break here, get page number.
c
          call getchar(lineq,iccount,durq)
          if (index('23456789',durq) .eq. 0) then
            call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *          'Need digit to define forced page break!')
            stop
          end if
          nfpb = nfpb+1
          ipagfpb(nfpb) = ichar(durq)-48
          isysfpb(nfpb) = isysflb(nflb)
        end if
      else if (charq .eq. 'F') then
        usefig = .false.
      else
        call errmsg(lineq,iccount,ibarcnt-ibaroff+nbars+1,
     *         'Illegal character!')
        stop
      end if
      return
      end
      subroutine getchar(lineq,iccount,charq)
      common /comget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt
      logical lastchar,issegno,isheadr,isvolt,fbon
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
      character*1 charq 
      character*128 lineq
      if (iccount .eq. 128) then
        read(10,'(a128)',end=999)lineq
        iccount = 0
        nline = nline+1
      end if
      iccount = iccount+1
      charq = lineq(iccount:iccount)
      return
999   continue
      lastchar = .true.
      return
      end
      function ifnodur(idur,dotq)
        character*1 dotq
        if (idur .eq. 6) then
          ifnodur=1
        else if (idur .eq. 3) then
          ifnodur=2
        else if (idur .eq. 1) then
          ifnodur=4 
        else if (idur .eq. 8) then
          ifnodur=8  
        else if (idur .eq. 4) then
          ifnodur=16 
        else if (idur .eq. 2) then
          ifnodur=32
        else if (idur .eq. 0) then
          ifnodur=64
        else if (idur .eq. 16) then
c
c  Only used for denominator of time signatures, not for notes
c
          ifnodur=4
        else 
          print*,'You entered an invalid note-length value:',idur
          stop
        end if
        if (dotq .eq. 'd') ifnodur = ifnodur*3/2
      return
      end
      subroutine makeabar()
      parameter (nm=7)
      common /all/ iv,list(4,200),nnl(nm),nv,ibar,
     *   ipl(nm,200),mtrnuml,
     *   nodur(nm,200),jn,lenbar,iccount,nbars,itsofar(nm),
     *   nib(nm,15),nn(nm),
     *   rest(nm,200),lenbr0,lenbr1,firstline,newmeter
      common /linecom/ elskb
      common /comnotes/ nnodur,wminnh(300),nnpd(2000),durb(2000),
     *     nptr(301),ibarcnt,ieminb(300),iemaxb(300),mbrest,ibarmbr,
     *     ibaroff
      common /commvl/ nvmx(nm),ivmx(nm,2),ivx,fbar
      logical rest,firstline,newmeter,intup,herext
      integer it(nm),cnn(nm),istart(20),istop(20),itstart(20),
     *   nspace(20),nindex(20)
      elskb = 0.
      ieminb(ibarcnt) = 1000
      iemaxb(ibarcnt) = 0
      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
2       list(1,ilnc) = ivx
        list(2,ilnc) = cnn(ivx)
        list(3,ilnc) = 0
        it(ivx) = nodur(ivx,cnn(ivx))
        if (nodur(ivx,cnn(iv)).eq.0) then
c
c  To keep all notes of xtup together, get another note from this voice 
c
          ilnc = ilnc+1
          cnn(ivx) = cnn(ivx)+1
          go to 2
        end if
        if (it(ivx) .eq. lenbar) it(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  itmin is the earliest ending time of notes done so far
c
      itmin = 1000
      do 6 iv = 1 , nv
      do 6 kv = 1 , nvmx(iv)
        ivx = ivmx(iv,kv)
        itminn = min(itmin,it(ivx))
        if(itminn .lt. itmin) then
          itmin = itminn
          ivnext = ivx
        end if
6     continue
      if (itmin .eq. 1000) go to 7
      list(1,ilnc) = ivnext
      cnn(ivnext) = cnn(ivnext)+1
      list(2,ilnc) = cnn(ivnext) 
      list(3,ilnc) = itmin
c
c  Check if this voice is done
c           
      if (cnn(ivnext) .eq. nn(ivnext)) then
        it(ivnext) = 1000
      else
        it(ivnext) = it(ivnext)+nodur(ivnext,cnn(ivnext)) 
      end if
      ilnc = ilnc+1
      go to 5
7     continue
      ntot = ilnc-1
      do 8 in = 1 , ntot-1
        list(4,in) = list(3,in+1)-list(3,in)
8     continue
      list(4,ntot) = nodur(list(1,ntot),list(2,ntot))
c
c  Debug writes
c
c     write(*,'(26i3)')(list(1,in),in=1,ntot)
c     write(*,'(26i3)')(list(2,in),in=1,ntot)
c     write(*,'(26i3)')(list(3,in),in=1,ntot)
c     write(*,'(26i3)')(list(4,in),in=1,ntot)
c     write(*,'(26i3)')(nodur(list(1,in),list(2,in)),in=1,ntot)
c
c  Done w/ list.  A kluged up loop for building note blocks:
c
      ib = 1 
      istart(1) = 1
      nspace(1) = 0
      in = 1 
9     continue
        if (in .eq. ntot) then
          if (nspace(ib) .eq. 0) nspace(ib)=list(4,in)
          istop(ib) = ntot
c
c Now we flow out of this if and into block-building      
c
        else if (nspace(ib) .eq. 0) then
c
c nspace hasn't been set yet, so tentatively set:
c
          nspace(ib) = list(4,in)
          if (nspace(ib) .eq. 0) then
            in=in+1
          else
            istop(ib) = in
          end if
          go to 9
        else if (list(4,in+1) .eq. 0) then
c
c This is not the last note in the group, so
c
          in = in+1
          go to 9 
        else if (list(4,in+1) .eq. nspace(ib)) then
c
c Keep spacing the same, update tentative stop point
c
          in = in+1
          istop(ib) = in
          go to 9
        end if
c
c At this point istart and istop are good, so close out block 
c
        itstart(ib) = list(3,istart(ib))
        nindex(ib) = kindxf(nspace(ib))
        ieminb(ibarcnt) = min(ieminb(ibarcnt),nindex(ib))
        iemaxb(ibarcnt) = max(iemaxb(ibarcnt),nindex(ib))
        elsperns = feon(float(nspace(ib)))
        if (istop(ib) .eq. ntot) then
          nnsk = (lenbar-itstart(ib))/nspace(ib)
        else
          nnsk = (list(3,istop(ib)+1)-itstart(ib))/nspace(ib)
        end if
        elskb = elskb+elsperns*nnsk
        if (nptr(ibarcnt+1) .gt. nptr(ibarcnt)) then
          call catspace(float(nspace(ib)),nnsk)
        else
c
c  This is the first entry for this bar
c
          nnpd(nptr(ibarcnt)) = nnsk
          durb(nptr(ibarcnt)) = nspace(ib)
          nptr(ibarcnt+1) = nptr(ibarcnt+1)+1
        end if
        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
        nspace(ib) = list(4,in)
        istop(ib) = in
      go to 9          
15    continue
      nb = ib
c     write(*,'(24i3)')(istart(ib),istop(ib),ib=1,nb)
c
c  Run through blocks, correcting elskb as needed for xtuplets 
c
      do 100 ib = 1 , nb
        herext = .false.
        intup = .false.
        do 101 in = istart(ib) , istop(ib)
          if (nodur(list(1,in),list(2,in)) .eq. 0) then
            if (.not.herext) then
c
c  New window with some number of xtups starts here.
c
              ntupm = 0
              herext = .true.
              itxstart = list(3,in)
            end if
            if (.not.intup) then
c
c  New xtup starts here
c
              ntup = 0
              intup = .true.
            end if
            ntup = ntup+1
            go to 101
          else if (intup) then
c
c  xtup ends here
c
            ntup = ntup+1
            lxtup = nodur(list(1,in),list(2,in))
            if (ntup .ge. ntupm) ntupm=ntup
            intup = .false.
          end if
          if (herext .and. 
     *        (in.eq.istop(ib).or.list(3,in+1).ne.itxstart)) then
c
c  Finished with all notes starting where xtup starts, so close out.
c
            ixtend = itxstart+lxtup
c
c  Compute "natural" length (in *elemskips) of xtuplet
c
            elxtup = ntupm*feon(lxtup/1./ntupm)
c
c  Compute natural lengths of other stuff spanning same time interval
c
            if (ixtend .le. list(3,istop(ib))+list(4,istop(ib))) then
c
c  xtup is contained in a single block
c
              nsk = lxtup/nspace(ib)
              elother = nsk*feon(lxtup/1./nsk)
            else
c
c  xtup spills over to next block
c
              ltime = itstart(ib+1)-itxstart
              nsk = ltime/nspace(ib)
              elother = nsk*feon(float(nspace(ib)))
              do 103 iib = ib+1 , nb
                if (ixtend .le. 
     *              list(3,istop(iib))+list(4,istop(iib))) then
                  ltime = ixtend-itstart(iib)
                  nsk = ltime/nspace(iib)
                  elother = elother+nsk*feon(float(nspace(iib)))
                  go to 104
                else
                  ltime = list(3,istop(iib))+list(4,istop(iib))
     *                                   -itstart(iib)
                  nsk = ltime/nspace(iib)
                  elother = elother+nsk*feon(float(nspace(iib)))
                end if
103           continue
            end if
104         continue
            elskb = elskb+dim(elxtup,elother)
            if (elxtup .gt. elother) then
c
c  Need to adjust catalog of tspaces
c
              call catspace(float(lxtup)/ntupm,ntupm)
              call catspace(float(lxtup),-1)
            end if
            herext = .false.
            ntupm = 0
          end if
101     continue
100   continue
c
c  Eliminate any zeroes in nnpd.  Manual loop since upper limit may change.
c
      iptr = nptr(ibarcnt)
105   continue
      if (iptr .gt. nptr(ibarcnt+1)-1) go to 106
      if (nnpd(iptr) .eq. 0) then
        nptr(ibarcnt+1) = nptr(ibarcnt+1)-1
        do 107 iiptr = iptr , nptr(ibarcnt+1)-1
          nnpd(iiptr) = nnpd(iiptr+1)
          durb(iiptr) = durb(iiptr+1)
107     continue
      else
        iptr = iptr+1
      end if
      go to 105
106   continue
      return
      end
      function feon(time)
c       feon = max(1.8,1.+alog(time/2)/.69315)
        feon = sqrt(time/2)
      return
      end
      function kindxf(nspace)
        kindxf = 2*alog(nspace*1.)/0.69315 + 1.3
      return
      end 
      function tspace(ie)
        if (mod(ie,2).eq.0) then
          tspace = .75*2.**(ie/2)
        else
          tspace = sqrt(2.**(ie-1))
        end if
      return
      end
      subroutine catspace(tspace,nnsk)
      common /comnotes/ nnodur,wminnh(300),nnpd(2000),durb(2000),
     *     nptr(301),ibarcnt,ieminb(300),iemaxb(300),mbrest,ibarmbr,
     *     ibaroff
      do 16 iptr = nptr(ibarcnt) , nptr(ibarcnt+1)-1
        if (abs(tspace-durb(iptr)) .lt. 0.001) then
c
c  Must increment old entry
c
          nnpd(iptr) = nnpd(iptr)+nnsk
          return
        end if
16    continue
c
c  Didn't find current duration, must add a new entry
c
      do 18 iptr = nptr(ibarcnt) , nptr(ibarcnt+1)-1
        if (tspace .lt. durb(iptr)) then
c
c  New entry will go at this iptr.  Bump up the rest
c
          do 19 jptr = nptr(ibarcnt+1)-1 , iptr , -1
            nnpd(jptr+1) = nnpd(jptr)
            durb(jptr+1) = durb(jptr)
19        continue
          nnpd(iptr) = nnsk
          durb(iptr) = tspace
          nptr(ibarcnt+1) = nptr(ibarcnt+1)+1
          return
        end if
18    continue
c
c  New entry goes at the end
c
      nnpd(nptr(ibarcnt+1)) = nnsk
      durb(nptr(ibarcnt+1)) = tspace
      nptr(ibarcnt+1) = nptr(ibarcnt+1)+1
      return
      end
      subroutine chklit(lineq,iccount,literr)
      character*128 lineq
      character*1 charq
      literr = 0
      itype = 1
17    call getchar(lineq,iccount,charq)
      if (charq .eq. char(92)) then
        itype = itype+1
        if (itype .gt. 3) then
          literr = 1
          return
        end if
        go to 17
      end if
      lenlit = itype
18    call getchar(lineq,iccount,charq)
      if (charq.eq.char(92)) then
        call getchar(lineq,iccount,charq)
        if (charq .ne. ' ') then
c
c  Starting a new tex command withing the string
c
          lenlit = lenlit+2
          if (lenlit .gt. 80) then
            literr = 2
            return
c           print*,'TeX string must have <80 char, end w/ " '
c    *         //char(92)//'"'
c           stop
          end if 
          go to 18
        end if
      else
        lenlit = lenlit+1
        if (lenlit .gt. 80) then
          literr = 2
          return
        end if 
        go to 18
      end if
      return
      end
      subroutine readnum(lineq,iccount,durq,fnum)
      character*128 lineq
      character*1 durq
      i1 = iccount
1     call getchar(lineq,iccount,durq)
      if (index('0123456789.',durq) .gt. 0) go to 1
      i2 = iccount-1
      if (i2 .lt. i1) then
        print*,'Found "'//durq//'" instead of number'
        stop
      end if
      icf = i2-i1+49
      read(lineq(i1:i2),'(f'//char(icf)//'.0)')fnum
      return
      end
      subroutine readmeter(lineq,iccount,mtrnum,mtrden)
      character*128 lineq
      character*1 durq
      call getchar(lineq,iccount,durq)
      if (durq .eq. '-') then
c
c  Negative numerator is used only to printed; signals vertical slash
c
        call getchar(lineq,iccount,durq)
        mtrnum = -(ichar(durq)-48)
      else if (durq .eq. 'o') then
c
c  Numerator is EXACTLY 1
c
        mtrnum = 1
      else
        mtrnum = ichar(durq)-48
        if (mtrnum .eq. 1) then
c
c  Numerator is >9
c
          call getchar(lineq,iccount,durq)
          mtrnum = 10+ichar(durq)-48
        end if
      end if
      call getchar(lineq,iccount,durq)
      if (durq .eq. 'o') then
        mtrden = 1
      else
        mtrden = ichar(durq)-48
        if (mtrden .eq. 1) then
          call getchar(lineq,iccount,durq)
          mtrden = 10+ichar(durq)-48
        end if
      end if
      return
      end
      subroutine errmsg(lineq,iccount,ibarno,msgq)
      common /comget/ lastchar,fbon,issegno,ihead,isheadr,nline,isvolt
      logical lastchar,fbon,issegno,isheadr,isvolt
      character*128 lineq
      character*78 outq
      character*128 msgq
      if (iccount .le. 78) then
        outq = lineq(1:78)
        iposn = iccount
      else
        outq = '... '//lineq(55:128)
        iposn = iccount-50 
      end if
      print*
      ndigbn = int(log10(ibarno+.1)+1)
      ndignl = int(log10(nline+.1)+1)
      lenmsg = index(msgq,'!')-1
      write(*,'(a15,i'//char(48+ndignl)//',a6,i'//char(48+ndigbn)//
     *',a)')' ERROR in line ',nline,', bar ',ibarno,': '//msgq(1:lenmsg)
      i10 = iposn/10
      i1 = iposn-10*i10
      write(*,'('//char(48+i10)//char(48+i1)//'x,a)')char(25)
      print*,outq(1:78)
      write(*,'('//char(48+i10)//char(48+i1)//'x,a)')char(24)
      return
      end
      block data
      common /compage/ widthpt,ptheight,nsyst,nflb,ibarflb(0:20),
     *      isysflb(0:20),npages,nfpb,ipagfpb(0:10),isysfpb(0:10),
     *      isig,usefig
      common /cblock/ 
     *      etatop,etabot,etait,etatc,etacs1,hgtin,hgtti,hgtco,
     *      xilbn,xilbtc,xilhdr,xilfig,a,b,inbothd,inhnoh  
      logical usefig
      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 /
      end