cccccccccccccccccccccccccccccccccccccccccccccccc
cc                                            cc
cc  scor2prt.for  Version 1.1 -  2/1/97       cc
cc                                            cc
cccccccccccccccccccccccccccccccccccccccccccccccc
      common /all/ noinst
      integer nvi(7)
      character*1 sq,achar(8)
      character*12 jobname
      character*79 instrum(7)
      character*128 line
      logical termrpt
      data achar /'P','m','V','R','A','h','w','K' /
      data nvi /7*1/
      print*,'jobname:'
      read(*,'(a)')jobname  
      ljob = lenstr(jobname,12)
      if (ljob .gt. 7) then
        print*,'Use a jobname with 7 or fewer letters'
        stop
      end if
      sq = char(92)
      open(10,file=jobname(1:ljob)//'.pmx')
      read(10,*)nv,noinst,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0,isig,
     *          npages,nsyst,musicsize,fracindent
      if (npages .eq. 0) then
        print*,
     *'You entered npages=0, which means nsyst is not the total number'
        print*,
     *'of systems.  Scor2prt has to know the total number of systems.'
        print*,
     *'Please set npages and nsyst to their real values.'   
        stop
      end if
      nppp = (nsyst-1)/12+1
      nvi(1) = nv-noinst+1
      do 1 iv = 1 , noinst
        open(10+iv,status='SCRATCH')
        write(10+iv,'(6i5,f7.3,i5/3i5,f8.5)')
     *          nvi(iv),1,mtrnuml,mtrdenl,mtrnmp,mtrdnp,xmtrnum0,isig,
     *          nppp,nsyst,20,0.05
        read(10,'(a)') instrum(iv)
c
c  The following checks for macro that write original C-clef as part of
c  instrument name.  See pmx.tex
c
        if (index(instrum(iv),'namewpc') .eq. 0) then
          write(10+iv,'(a)')' '
        else
          inm1 = index(instrum(iv),'{')+1
          inm2 = index(instrum(iv),'}')-1
          read(instrum(iv)(inm2+2:inm2+8),'(i1,4x,2i1)')ilev,iy1,iy2
          write(10+iv,'(a)')sq//'namewpc{}'//char(ilev+48)//'{20}'//
     *      char(iy1+49)//char(iy2+49)
          instrum(iv) = instrum(iv)(inm1:inm2)
        end if
1     continue
c
c  Clef string
c
      read(10,'(a)') line
      do 2 iv = 1 , noinst
        if (iv .eq. 1) then
          write(10+iv,'(a'//char(49+nv-noinst)//')')line(1:nv-noinst+1)
        else
          write(10+iv,'(a1)')line(nv-noinst+iv:nv-noinst+iv)
        end if
2     continue
c
c  Path string
c
      read(10,'(a)') line
      call allparts(line,128)
c
c  Write instrument names.  Will be blank if later part of a score.
c
      if (instrum(1)(1:1) .ne. ' ') then
        do 3 iv = 1 , noinst
          len = lenstr(instrum(iv),79)
          write(10+iv,'(a2/a)')'Ti',instrum(iv)(1:len)
3       continue
      end if
c
c  The big loop.  Except for '%%', put all comment lines in all parts.
c  Unless preceeded by '%%', put all type 2 or 3 TeX Strings in all parts
c  If a line starts with %!, put the rest of it in each part.
c  If a line starts with %[n], put the rest of it in part [n].
c  Check for Tt, Tc, Voltas, Repeats, headers, lower texts, meter changes.
c     Assume they only come at top of block, except terminal repeat needs
c     special handling.
c  Check for "P"; ignore in parts.
c  Check for consecutive full-bar rests; if found, replace with rm[nn]
c
      iv = 1
      iinst = 1
      termrpt = .false.
4     read(10,'(a)',end=999)line
      if (line(1:2).eq. '%%') then
c
c  Ignore next line
c
        read(10,'(a)')line
        if (index('h XXl ',line(1:2)).gt.0) read(10,'(a)')line
        go to 4
      else if (line(1:1).eq.'%' .and. 
     *            index('1234567',line(2:2)).gt.0) then
        lenline = lenstr(line,128)
        write(10+ichar(line(2:2))-48,'(a)')line(3:lenline)
        go to 4
      else if (line(1:2) .eq. '%!') then
        call allparts(line(3:128),126)
        go to 4
      else if (line(1:1) .eq. 'T') then
        call allparts(line,128)
        read(10,'(a)')line
        call allparts(line,128)
        go to 4
      else if (line(1:2).eq.sq//sq .or. line(1:1).eq.'%') then
        call allparts(line,128)
        go to 4
      else if (index('hl',line(1:1)).gt.0 .and.
     *    line(2:2).eq.' ') then
        call allparts(line(1:1),1)
        read(10,'(a)')line
        call allparts(line,128)
        go to 4
      else if (iv .eq. 1) then
        do 5 ia = 1 , 8
          idxa = ntindex(line,achar(ia))
          if (idxa.gt.0 .and. 
     *        (idxa.eq.1 .or. line(idxa-1:idxa-1).eq.' ')) then 
c
c  Find next blank
c
            do 6 ib = idxa+1 , 128
              if (line(ib:ib) .eq. ' ') go to 7
6           continue
            print*,'Problem with "V,R,m,P,A,h, or w"'
            print*,'Send files to Dr. Don at dsimons@logicon.com'
            stop
7           continue
c
c  Next blank is at position ib
c
            if (ia .eq. 4) then
c
c  Check for terminal repeat.  Note if there's a term rpt, there can't be any
c  others.  Also, must process repeats LAST, after m's and 'V's
c
              do 8 ic = ib+1 , 128
                if (index(' /',line(ic:ic)) .eq. 0) go to 9
                if (line(ic:ic) .eq. '/') then
                  termrpt = .true.
c
c  Process the line as if there were no "R"
c
                  go to 10
                end if
8             continue
c
c  If here, all chars after "R" symbol are blanks, so process the line normally
c
            else if (ia .eq. 1) then
c
c  Do not transfer P into parts.
c
              go to 12
            end if
9           continue
            call allparts(line(idxa:ib-1),ib-idxa)
12          continue
c
c  Remove the string from line
c
            if (idxa .eq. 1) then
              line = line(ib:128)
            else
              line = line(1:idxa-1)//line(ib:128)
            end if 
c
c  Loop if only blanks are left
c
            if (lenstr(line,128) .eq. 0) go to 4
          end if
5       continue
      end if
10    continue
      lenline = lenstr(line,128)
      if (termrpt .and. iv.gt.nv-noinst+1 .and. 
     *             line(lenline:lenline).eq.'/') then
c
c  Must add a terminal repeat before the slash
c
        write(10+iinst,'(a)')line(1:lenline-1)
        line = 'Rr /'
        lenline = 4
        if (iv .eq. nv) termrpt = .false.
      end if
      write(10+iinst,'(a)')line(1:lenline)
      if (ntindex(line,'/').gt.0 .and. index(line,'//').eq.0) then
        iv = 1+mod(iv,nv)
        if (iv.eq.1 .or. iv.gt.nvi(1)) iinst = 1+mod(iinst,noinst)
      end if
      go to 4
999   continue
      close(10)
      do 11 iinst = 1 , noinst
        if (nvi(iinst) .eq. 1) then
          call mbrests(iinst,jobname,ljob)
        else
c
c  Send a signal to bypass mbrest processing
c
          call mbrests(iinst,jobname,-ljob)
        end if
11    continue
      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 allparts(string,n)
      character*(*) string
      common /all/ noinst
      len = lenstr(string,n)
      do 1 iv = 1 , noinst
        write(10+iv,'(a)')string(1:len)
1     continue
      return
      end
      subroutine mbrests(iv,jobname,ljob)
      character*128 line(10),line1
      character*80 sym
      character*12 jobname
      character*3 wbrsym(2)
      character*1 sq
      logical wbrest,alldone,rpfirst
      sq = char(92)
      alldone = .false.
      rewind(10+iv)
      open(20,file=jobname(1:abs(ljob))//char(48+iv)//'.pmx')
      do 1 i = 1 , 10000
        read(10+iv,'(a)',end=999)line(1)
7       len = lenstr(line(1),128)
c
c  Pass-through if inst. #1 has >1 voice.
c
        if (ljob .lt. 0) go to 2
        if (i.eq.1 .or. (i.gt.5.and.line(1)(1:1).eq.'m')) then
          if (i .eq. 1) then
            read(line(1),'(10x,2i5)')mtrnum,mtrden
          else 
            icden = 3
            if (line(1)(2:2) .eq. 'o') then
              mtrnum = 1
            else
              mtrnum = ichar(line(1)(2:2))-48
              if (mtrnum .eq. 1) then
                icden = 4
                mtrnum = 10+ichar(line(1)(3:3))-48
              end if
            end if
            mtrden = ichar(line(1)(icden:icden))-48
          end if
          lenbeat = ifnodur(mtrden,'x')
          lenmult = 1
          if (mtrden .eq. 2) then
            lenbeat = 16
            lenmult = 2
          end if
          lenbar = lenmult*mtrnum*lenbeat
          call fwbrsym(lenbar,nwbrs,wbrsym,lwbrs)
        end if
        ip1 = 0
        line1 = line(1)
        do 3 iw = 0 , nwbrs
          if (iw .gt. 0) then
            idx = ntindex(line1,wbrsym(iw)(1:lwbrs))
          else
            idx = ntindex(line1,'rp')
          end if
          if (idx .gt. 0) then
            if (ip1. eq. 0) then
              ip1 = idx
            else
              ip1 = min(ip1,idx)
            end if
          end if
3       continue
        if (i.le.5 .or. line(1)(1:1).eq.'%' .or. line(1)(1:2).eq.sq//sq
     *       .or. ip1.eq.0) go to 2
c
c  Switch to multibar rest search mode!!!  Start forward in line(1)
c
        rpfirst = line1(ip1:ip1+1) .eq. 'rp'
        iline = 1
        nmbr = 1
        if (rpfirst) then
          lwbrsx = 2
        else
          lwbrsx = lwbrs
        end if
        ipe = ip1+lwbrsx-1
4       if (ipe .eq. len) then
c
c  Need a new line 
c
          iline = iline+1
6         read(10+iv,'(a)',end=998)line(iline)
          len = lenstr(line(iline),128)
          if (line(iline)(1:1).eq.'%' ) then
            write(20,'(a)')'% Following comment has been moved forward'
            write(20,'(a)')line(iline)(1:len)
            go to 6
          end if
          ipe = 0
          go to 4
998       continue
c
c  No more input left
c
      print*,'All done!'
          alldone = .true.
          ipe = 0
          iline = iline-1
          go to 4
        else
          if (alldone) then
            sym(1:1) = ' '
          else
c
c  ipe<len here, so it's ok to get a symbol
c
            call nextsym(line(iline),len,ipe,ipenew,sym,lsym)
          end if
c
c  Check for end of block or bar line symbol
c
          if (index('/|',sym(1:1)) .gt. 0) then
            ipe = ipenew
            go to 4
          else 
            wbrest = .false.
            if (alldone) go to 12
            do 5 iw = 1 , nwbrs
              wbrest = wbrest .or. sym(1:lsym).eq.wbrsym(iw)(1:lwbrs)
5           continue
            wbrest = wbrest .or. (sym(1:lsym).eq.'r'.and.lwbrs.eq.2) 
     *                .or. (sym(1:lsym).eq.'rd'.and.lwbrs.eq.3) 
     *                .or. (sym(1:lsym).eq.'rp') 
     *                .or. (sym(1:lsym).eq.'r' .and. rpfirst)
12          if (wbrest) then
              ipe = ipenew
              nmbr = nmbr+1
              go to 4
            else 
c
c  AHA! Failed prev. test, so last symbol was *not* mbr.
c  It must be saved, and its starting position is ipenew-lsym+1
c
              if (nmbr .gt. 1) then
c
c  Write stuff up to start of mbr
c
                if (ip1 .gt. 1) write(20,'(a)')line(1)(1:ip1-1)
c
c  Insert mbr symbol.  Always end with a slash just in case next sym must be 
c  at start of block.  May think this causes undefined octaves, but
c  probably not since it's a single voice.
c
                ndig = int(alog10(nmbr+.01))+1
      print*,'Inserting rm, iv,nmbr:',iv,nmbr
                write(20,'(a2,i'//char(48+ndig)//',a2)')'rm',nmbr,' /'
                if (alldone) go to 999
                ipc = ipenew-lsym+1
                line(1) = line(iline)(ipc:len)
              else
c
c  Write old stuff up to end of original lonesome wbr, save the rest.
c  4 cases:  (wbr /) , (wbr line-end) , (wbr followed by other non-/ symbols) ,
c      alldone.
c  In 1st 2 will have gotten some other lines, so write all up to one b4 last 
c  non-comment line; then revert to normal mode on that.  In 3rd case must 
c  split line.
c
                if (alldone) then
                  write(20,'(a)')line(1)(1:len)
                  go to 999
                else if (iline .gt. 1) then
                  do 9 il = 1 , iline-1
                    len = lenstr(line(il),128)
                    write(20,'(a)')line(il)(1:len)
9                 continue
                  line(1) = line(iline)
                else
c
c  Since iline = 1 the wbr is not the last sym, so must split
c
                  write(20,'(a)')line(1)(1:ip1+lwbrsx-1)
                  line(1) = line(1)(ip1+lwbrsx+1:len)
                end if
              end if
c
c  Exit multibar mode
c
              go to 7
            end if
          end if
        end if
2       write(20,'(a)')line(1)(1:len)
1     continue
999   continue
      close(10+iv)
      close(20)
      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 
          print*,'You entered an invalid note-length value'
          stop
        end if
        if (dotq .eq. 'd') ifnodur = ifnodur*3/2
      return
      end
      subroutine fwbrsym(lenbar,nwbrs,wbrsym,lwbrs)
      character*3 wbrsym(2)
        nwbrs = 1
        lwbrs = 2
        if (lenbar .eq. 16) then
          wbrsym(1) = 'r4'
        else if (lenbar .eq. 32) then
          wbrsym(1) = 'r2'
        else if (lenbar .eq. 64) then
          wbrsym(1) = 'r0'
        else if (lenbar .eq. 8) then
          wbrsym(1) = 'r8'
        else
          nwbrs = 2
          lwbrs = 3
          if (lenbar .eq. 24) then
            wbrsym(1) = 'rd4'
            wbrsym(2) = 'r4d'
          else if (lenbar .eq. 48) then
            wbrsym(1) = 'rd2'
            wbrsym(2) = 'r2d'
          else if (lenbar .eq. 96) then
            wbrsym(1) = 'rd0'
            wbrsym(2) = 'r0d'
          else
            write(*,'(33H Any whole-bar rests of duration ,i3,
     *        26H/64 will not be recognized)') lenbar
          end if
        end if
      return
      end           
      subroutine nextsym(line,len,ipeold,ipenew,sym,lsym)
c
c  Know its the last symbol if on return ipenew = len!.  So should never 
c    be called when ipstart=len.
c
        character*128 line
        character*80 sym
        if (ipeold .ge. len) then
          print*,'Called nextsym with ipstart>=len '
          print*,'Send files to Dr. Don at dsimons@logicon.com'
          stop
        end if
        do 1 ip = ipeold+1 , len
          if (line(ip:ip) .ne. ' ') then
c
c  symbol starts here (ip).  We're committed to exit the loop.
c
            if (ip .lt. len) then
              do 2 iip = ip+1 , len
                if (line(iip:iip) .ne. ' ') go to 2
c
c  iip is the space after the symbol
c
                ipenew = iip-1
                lsym = ipenew-ip+1
                sym = line(ip:ipenew)
                return
2             continue
c
c  Have len>=2 and ends on len
c
              ipenew = len
              lsym = ipenew-ip+1
              sym = line(ip:ipenew)
              return
            else 
c
c  ip = len
c
              ipenew = len
              lsym = 1
              sym = line(ip:ip)
              return
            end if 
          end if
1       continue        
      print*,'Error #3.  Send files to Dr. Don at dsimons@logicon.com'
      end                
      function ntindex(line,s2q)
c
c  Returns index(line,s2q) if NOT in TeX string, 0 otherwise
c
      character*(*) s2q
      character*128 line
      logical intex
c
c     print*,'Starting ntindex.  s2q:',s2q,', line(1:79) is below'
c     print*,line(1:79)
c
      ndxs2 = index(line,s2q)
      ndxbs = index(line,char(92))
      if (ndxbs.eq.0 .or. ndxs2.lt.ndxbs) then
        ntindex = ndxs2
c     print*,'No bs, or char is left of 1st bs, ntindex:',ntindex
      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,128)
        intex = .true.
c     print*,'intex+>',intex
        do 1 ic = ndxbs+1 , len
          if (ic .eq. ndxs2) then
            if (intex) then
              ntindex = 0
              ndxs2 = index(line(ic+1:len),s2q)+ic
c     print*,'ndxs2 =>',ndxs2
            else
              ntindex = ndxs2
              return
            end if
c     print*,'Internal exit, intex, ntindex:',intex,ntindex 
          else if (intex .and. line(ic+1:ic+2).eq.char(92)//' ') then
            intex = .false.
c     print*,'intex+>',intex
          else if (.not.intex .and. line(ic+1:ic+2).eq.' '//char(92)) 
     *           then
            intex = .true.
c     print*,'intex+>',intex
          end if
1       continue
c     print*,'Out end of loop 1'
      end if
c     print*,'Exiting ntindex at the end???'
      return
      end