home *** CD-ROM | disk | FTP | other *** search
/ BCI NET 2 / BCI NET 2.iso / archives / applications / wp / pmtex.lha / pmtex / src / pmtexb.for < prev    next >
Encoding:
Text File  |  1995-03-05  |  48.0 KB  |  1,592 lines
  1. ccccccccccccccccccccccccccccccc
  2. cc                           cc
  3. cc  pmtexb.for Version 1.0   cc
  4. cc                           cc
  5. ccccccccccccccccccccccccccccccc
  6. cc
  7. cc  file pmtex.inc
  8. cc
  9. cc      common /all/ mult(5,200),iv,list(4,200),nnl(5),nv,ibar,
  10. cc     *   ipl(5,200),ibm1(5,8),ibm2(5,8),nolev(5,200),ibmcnt(5),
  11. cc     *   nodur(5,200),ncmid(5),jn,lenbar,iccount,nbars,itsofar(5),
  12. cc     *   nib(5,15),nn(5),
  13. cc     *   rest(5,200),beamon(5) ,lenbar0,lenbar1,firstline,
  14. cc     *   slfac,musicsize,stemmax,stemmin,stemlen
  15. cc      common /all/ acc(5,200),ul(5,8),hb(5,8),orn(5,200),
  16. cc     *   fig(200),sepsym,s
  17. cc      character*6 fig
  18. cc      character*1 acc,ul,hb,orn,sepsym,s
  19. cc      logical beamon,rest,firstline
  20. cc
  21. cccccccccccccccccccccccccccccc
  22.       include 'pmtex.inc'
  23.       logical loop,lastchar,figbass
  24.       character*1  clef(5)
  25.       character*80 line
  26.       character*40 pathname
  27.       character*24 autoline,basename,iname
  28.       common /comfig/ ifigdrop(50),iline,figbass
  29.       common /comget/ lastchar
  30.       common /combeam/ lenbeam
  31.       common /comtop / itopfacteur,ibotfacteur,interfacteur,
  32.      *   isig,fracindent,imeter,mtrnum,mtrden,iwaskpt,widthpt,height
  33.       common /comtop/ iname(5)
  34. c
  35. c  iccount: pointer in string from input file.  Just before calling getchar,
  36. c          it points to the last character retrieved. 
  37. c  nnl    : # of notes in a line (//)
  38. c  itsofar: time in current line from start of line
  39. c
  40.       widthpt = 524
  41.       iwaskpt = 3
  42.       height = 770.
  43.       slfac1 = 0.00569  
  44.       stemmax = 8.2 
  45.       stemmin = 3.9
  46.       stemlen = 6.0
  47. c  Platform-independent backslash
  48.       s = char(92)
  49.       open(12,file='pmtex.dat')
  50.       read(12,'(a)')basename
  51.       read(12,*)lbase
  52.       read(12,*)itopfacteur,ibotfacteur,interfacteur,iauto
  53.       open(10,file=basename(1:lbase)//'.inp')
  54.       read(10,*)nv,noinst,mtrnum,mtrden,imeter,xmtrnum0,isig,
  55.      *          lpp,nstaves,musicsize,fracindent
  56. c
  57. c imeter = 0 for fraction        noinst = 0  if several voices, 1 inst
  58. c          2,3,4  single-digit            nv if separate inst's
  59. c          5 for cut time
  60. c          6 for common time
  61. c
  62.       do 6 iv = 1 , nv
  63.         read(10,'(a24)')iname(iv)
  64. 6     continue
  65.       read(10,'(a80)')line
  66.       do 7 iv = 1 , nv
  67.         clef(iv) = line(iv:iv)
  68. 7     continue
  69.       read(10,'(a)')pathname
  70.       lpath = index(pathname,' ')-1
  71.       open(13,file='pmtex.fig')
  72.       figbass = .false.
  73.       read(13,*)ifig
  74.       if (ifig .eq. 1) then
  75.         figbass = .true.
  76.         iline = 1
  77.         ifigdrop(1) = 4
  78.         open(14,file=pathname(1:lpath)//basename(1:lbase)//'.fig')
  79.         write(14,'(a)')
  80.      *    s//'def'//s//'fixdrop{'//s//'ifcase'//s//'sysno%'
  81.       end if
  82.       lastchar = .false.
  83. c  Bar count offset
  84.       ibcoff = 0
  85.       if (xmtrnum0 .gt. 0.) ibcoff = -1
  86.       open(11,file=pathname(1:lpath)//basename(1:lbase)//'.tex')
  87.       sepsym = '|'
  88.       if (noinst .gt. 1) sepsym = '&'
  89.       call topfile(basename,lbase,nv,clef,noinst,musicsize,figbass)
  90.       lenbeat = ifnodur(mtrden,'x')
  91.       lenbar = mtrnum*lenbeat
  92.       lenbar1 = mtrnum*lenbeat
  93.       lenbar0 = xmtrnum0*lenbeat+.5
  94.       if (lenbar0 .ne. 0) then
  95.         write(11,'(a)')s//'advance'//s//'barno by -1'
  96.         lenbar = lenbar0
  97.       else
  98.         lenbar = lenbar1
  99.       end if
  100. c### The following may need revision for different time sig's.
  101.       if (mtrden .eq. 4) then
  102.         lenbeam = 24
  103.       else if (mtrden .eq. 8) then
  104.         lenbeam = 36
  105.       end if
  106.       ibarcnt = 0
  107.       iccount = 80
  108.       do 1 iv = 1 , nv
  109.         ncmid(iv) = ncmidf(clef(iv))
  110. 1     continue
  111. c
  112. c  Initialize for loop over lines
  113. c
  114.       firstline = .true.
  115. 30    loop = .true.
  116.       nbars = 0
  117. 3     do 4 iv = 1 , nv
  118.         itsofar(iv) = 0
  119.         nnl(iv) = 0
  120.         do 5 j = 1 , 200
  121.           rest(iv,j) = .false.
  122.           acc(iv,j) = 'x'
  123.           orn(iv,j) = 'x'
  124.           if (iv .eq. 1) fig(j) = 'x'
  125. 5       continue
  126. 4     continue 
  127.       iv = 1
  128. 2     if (loop) then
  129. c
  130. c  Within this loop, nv voices are filled up for the duration of the line.
  131. c  On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv)
  132. c  nolev(nv,nnl(nv)),nodur(..),acc(..),rest(..).  nnl will later be
  133. c  increased and things slid around as accidental skips are added.  
  134. c
  135.         call getnote(loop) 
  136.         if (lastchar) go to 40
  137.         go to 2
  138.       end if
  139.       firstline = .false.
  140.       do 10 ibar = 1 , nbars
  141.         ibarcnt = ibarcnt+1
  142.         print*,'Now processing bar #',ibarcnt+ibcoff
  143.         write(11,'(a5,i3)')'% bar',ibarcnt+ibcoff
  144.         if (ibarcnt .gt. 1) then
  145.           write(11,'(a6)')s//'barre'
  146.           if (ibarcnt.eq.iauto .and. figbass) then
  147.             write(14,'(a16,i2,a10)')
  148.      *        s//'global'//s//'figdrop=',ifigdrop(iline),
  149.      *        s//'relax'//s//'or%'
  150.             iline = iline+1
  151.             ifigdrop(iline) = 4
  152.           end if
  153.         end if
  154.         if (ibarcnt .eq. iauto) then
  155.           read(12,'(a24)')autoline
  156.           read(autoline,'(7x,i2,2x,i2)')ielperbar,ibarperln
  157.           slfac = slfac1*musicsize*ielperbar*ibarperln
  158.           write(11,'(a24)')autoline
  159.           read(12,*)iauto
  160.         end if
  161.         if (ibar .gt. 1) then
  162. c
  163. c  For bars after first, slide all stuff down to beginning of arrays
  164. c
  165.           do 11 iv = 1 , nv
  166.             ioff = nib(iv,ibar-1)
  167.             do 12 ip = 1 , nib(iv,ibar)-ioff
  168.               nolev(iv,ip) = nolev(iv,ip+ioff)
  169.               nodur(iv,ip) = nodur(iv,ip+ioff)
  170.               acc(iv,ip) = acc(iv,ip+ioff)
  171.               rest(iv,ip) = rest(iv,ip+ioff)
  172.               orn(iv,ip) = orn(iv,ip+ioff)
  173.               if (iv.eq.1) fig(ip) = fig(ip+ioff)
  174. 12          continue
  175. 11        continue
  176.         end if
  177.         call makeabar()
  178. 10    continue
  179.       go to 30
  180. 40    close(12)
  181.       close(13)
  182.       close(10)
  183.       close(11)
  184.       if (figbass) then
  185.         write(14,'(a16,i2,a10)')
  186.      *        s//'global'//s//'figdrop=',ifigdrop(iline),
  187.      *        s//'relax'//s//'fi}%'
  188.         close(14)
  189.       end if
  190.       print*,'Writing ',pathname(1:lpath)//basename(1:lbase)//'.tex '
  191.      *  //'and exiting'
  192.       end
  193.       subroutine getnote(loop)
  194.       include 'pmtex.inc'
  195.       common /comget/ lastchar
  196.       character*80 line
  197.       logical loop,lastchar
  198.       character*1 char,oct,dot
  199. 1     call getchar(line,iccount,char)
  200.       if (lastchar) return
  201.       if (char .eq. ' ') then
  202.         go to 1
  203.       else if (char .eq. '%') then
  204.         iccount = 80
  205.         go to 1
  206.       else if (ichar(char).ge.97 .and. ichar(char).le.103) then
  207. c
  208. c This is a note.  Increase note count, get octave & basic duration.
  209. c
  210.         nnl(iv) = nnl(iv)+1
  211.         call getchar(line,iccount,oct)
  212.         if (lastchar) return
  213.         dot = 'x'
  214.         if (oct .ne. ' ') then
  215.           read(oct,'(i1)')ioct
  216.           nolev(iv,nnl(iv)) = ifnolev(char,ioct)
  217.           call getchar(line,iccount,char)
  218.           if (lastchar) return
  219.         else
  220. c#### Get octave from previous one
  221.           nolev(iv,nnl(iv)) = ifnolev(char,ioct)
  222.           if (nolev(iv,nnl(iv)) .gt. nolev(iv,nnl(iv)-1)+3) then
  223.             nolev(iv,nnl(iv)) = nolev(iv,nnl(iv))-7
  224.           else if (nolev(iv,nnl(iv)) .lt. nolev(iv,nnl(iv)-1)-3) then
  225.             nolev(iv,nnl(iv)) = nolev(iv,nnl(iv))+7
  226.           end if
  227.           char = ' '
  228.         end if 
  229.         if (char .eq. ' ') then
  230.           nodur(iv,nnl(iv)) = nodur(iv,nnl(iv)-1)
  231.           go to 4
  232.         end if
  233.         read(char,'(i1)')inodur
  234. 2       call getchar(line,iccount,char)
  235.         if (lastchar) return
  236.         if (char .ne. ' ') then
  237.           if (char .eq. 'd') then
  238.             dot = char
  239.           else if (char .eq. '/') then
  240.             continue
  241.           else
  242. c
  243. c  Only other possibility is an accidental
  244. c
  245.             acc(iv,nnl(iv)) = char
  246.           end if
  247.           if (char .ne. '/') go to 2
  248.         end if
  249.         nodur(iv,nnl(iv)) = ifnodur(inodur,dot)
  250. 4       itsofar(iv) = itsofar(iv)+nodur(iv,nnl(iv))
  251.         if (mod(itsofar(iv),lenbar) .eq. 0) then
  252.           nbars = nbars+1
  253.           nib(iv,nbars) = nnl(iv)
  254.           if (lenbar .ne. lenbar1) then
  255. c
  256. c###  Just finished the pickup bar for this voice.
  257. c
  258.             lenbar = lenbar1
  259.             itsofar(iv) = 0
  260.           end if
  261.         end if 
  262.       else if (char .eq. 'o') then
  263. c###             "o" symbol must come AFTER the affected note
  264.         call getchar(line,iccount,orn(iv,nnl(iv))) 
  265.         if (lastchar) return
  266.       else if ((ichar(char).ge.49.and.ichar(char).le.57) .or.
  267.      *    char.eq.'#' .or. char.eq.'-' .or. char.eq.'n'
  268.      *    .or. char.eq.'_') then
  269. c###            We have a figure.  Must come AFTER the note it goes under
  270.         lfig = 1
  271.         fig(nnl(iv)) = char
  272. 5       call getchar(line,iccount,char)
  273.         if (lastchar) return
  274.         if (char .ne. ' ') then
  275.           fig(nnl(iv)) = fig(nnl(iv))(1:lfig)//char
  276.           lfig = lfig+1
  277.           go to 5
  278.         end if
  279.       else if (char .eq. 'r') then
  280. c
  281. c  We have a rest, so get inodur and dot
  282. c
  283.         nnl(iv) = nnl(iv) + 1
  284.         rest(iv,nnl(iv)) = .true.
  285.         call getchar(line,iccount,char)
  286.         if (lastchar) return
  287.         read(char,'(i1)')inodur
  288.         dot = 'x'
  289.         call getchar(line,iccount,char)
  290.         if (lastchar) return
  291.         if (char .eq. 'd') then
  292.           dot = char
  293.         end if 
  294.         nodur(iv,nnl(iv)) = ifnodur(inodur,dot)
  295.         itsofar(iv) = itsofar(iv)+nodur(iv,nnl(iv))
  296.         if (mod(itsofar(iv),lenbar) .eq. 0) then
  297.           nbars = nbars+1
  298.           nib(iv,nbars) = nnl(iv)
  299.           if (lenbar .ne. lenbar1) then
  300. c
  301. c###  Just finished the pickup bar for this voice.
  302. c
  303.             lenbar = lenbar1
  304.             itsofar(iv) = 0
  305.           end if
  306.         end if 
  307.       end if
  308. 3     if (char .eq. '/') then
  309. c
  310. c  Start a new voice for this line
  311. c
  312.         if (iv .eq. nv) then
  313.           loop = .false.
  314.         else
  315.           if (lenbar0.ne.0 .and. firstline) lenbar = lenbar0
  316.           nbars = 0
  317.           iv = iv+1
  318.         end if
  319.       end if
  320.       return
  321.       end
  322.       subroutine getchar(line,iccount,char)
  323. c
  324. c  Gets the next character out of line*80.  If pointer iccount=80 on entry,
  325. c  then reads in a new line.  Resets iccount.  Ends program if no more input.  
  326. c
  327.       logical lastchar
  328.       common /comget/ lastchar
  329.       character*1 char,s 
  330.       character*80 line
  331. c  Platform-independent backslash
  332.       s = char(92)
  333.       if (iccount .eq. 80) then
  334.         read(10,'(a80)',end=999)line
  335.         iccount = 0
  336.       end if
  337.       iccount = iccount+1
  338.       char = line(iccount:iccount)
  339.       return
  340. 999   continue
  341.       write(11,'(a)')s//'finmorceau'//s//'bye'
  342.       lastchar = .true.
  343.       return
  344.       end
  345.       function log2(n)
  346.         log2 = alog(n*1.)/0.69315+.01
  347.       return
  348.       end
  349.       function ifnolev(no,oct)
  350.         character*1 no
  351.         integer oct
  352.         ifnolev = 7*oct+mod(ichar(no)-92,7)+1
  353.       return
  354.       end
  355.       function ifnodur(idur,dot)
  356.         character*1 dot
  357.         if(idur .eq. 3)then
  358.           ifnodur=3
  359.         else if(idur .eq. 1) then
  360.           ifnodur=6 
  361.         else if(idur .eq. 8) then
  362.           ifnodur=12 
  363.         else if(idur .eq. 4) then
  364.           ifnodur=24 
  365.         else if(idur .eq. 2) then
  366.           ifnodur=48
  367.         else if(idur .eq. 0) then
  368.           ifnodur=96
  369.         else 
  370.           print*,'You entered an invalid note value'
  371.           stop
  372.         end if
  373.         if (dot .eq. 'd') ifnodur = ifnodur*1.5+.5
  374.       return
  375.       end
  376.       function ncmidf(clef)
  377.       character*1 clef
  378.       if (clef.eq.'t') then
  379.         ncmidf = 35
  380.       else if (clef .eq. 'b') then
  381.         ncmidf = 23
  382.       else if (clef .eq. 'a') then
  383.         ncmidf = 29
  384.       end if
  385.       return
  386.       end
  387.       subroutine beamend(notex,lnote)
  388.       include 'pmtex.inc'
  389.       character*1 notef
  390.       character*25 notex
  391.         ip = list(2,jn)
  392.         notex = s  
  393.         lnote = 1
  394. c
  395. c First check if multiplicity has increased
  396. c
  397.         if (acc(iv,ip-1) .ne. 'a') then
  398.           mp = mult(iv,ip-1)
  399.         else
  400.           mp = mult(iv,ip-2)
  401.         end if
  402.         if (mult(iv,ip) .gt. mp) then
  403.           notex = notex(1:1)//'t'
  404.           lnote = lnote+1
  405.           do 1 im = 1 , mult(iv,ip)
  406.             notex = notex(1:lnote)//'b'
  407.             lnote = lnote+1
  408. 1         continue
  409.           notex = notex(1:lnote)//ul(iv,ibmcnt(iv))
  410.           lnote = lnote+2
  411.           write(notex(lnote:lnote),'(i1)')iv
  412.           notex = notex(1:lnote)//s
  413.           lnote = lnote+1
  414.         end if
  415. c
  416. c Now the normal beam termination
  417. c
  418.         notex = notex(1:lnote)//'tb'//ul(iv,ibmcnt(iv))
  419.         lnote = lnote+4
  420.         write(notex(lnote:lnote),'(i1)')iv
  421. c
  422. c  And now the note
  423. c
  424.         notex = notex(1:lnote)//s//'q'//hb(iv,ibmcnt(iv))
  425.         lnote = lnote+4
  426.         write(notex(lnote:lnote),'(i1)')iv
  427.         notex = notex(1:lnote)//notef(nolev(iv,ip))
  428.         lnote = lnote+1
  429.       return
  430.       end
  431.       subroutine beamid(notex,lnote)
  432.       include 'pmtex.inc'
  433.       character*25 notex
  434.       character*1 notef
  435.         lnote = 1
  436.         notex = s
  437.         ip = list(2,jn)
  438. c
  439. c Check if multiplicity changes in a way requiring action
  440. c
  441.         mub = mult(iv,ip)-mult(iv,ip-1)
  442.         if (acc(iv,ip-1).eq.'a') mub = mult(iv,ip)-mult(iv,ip-2)
  443.         mua = mult(iv,ip+1)-mult(iv,ip)
  444.         if (acc(iv,ip+1).eq.'a') mua = mult(iv,ip+2)-mult(iv,ip)
  445.         if (mub.gt.0 .or. mua .lt. 0) then
  446. c
  447. c  Multiplicity has changed.
  448. c
  449.           lnote = 2
  450.           if (mua .ge. 0) then
  451.             notex = s//'n'
  452.           else
  453.             notex = s//'t'
  454.           end if
  455.           do 1 im = 1 , mult(iv,ip)
  456.             notex = notex(1:lnote)//'b'
  457.             lnote = lnote+1
  458. 1         continue
  459.           notex = notex(1:lnote)//ul(iv,ibmcnt(iv))
  460.           lnote = lnote+2
  461.           write(notex(lnote:lnote),'(i1)')iv
  462.           notex = notex(1:lnote)//s
  463.           lnote = lnote+1
  464.         end if
  465. c
  466. c Now put in the note
  467. c
  468.         notex = notex(1:lnote)//'q'//hb(iv,ibmcnt(iv))
  469.         lnote = lnote+2
  470.         if (acc(iv,ip).ne.'a'.and. 2**log2(int(nodur(iv,ip)/3.+.1)).ne.
  471.      *                                    int(nodur(iv,ip)/3.+.1)) then      
  472.           notex = notex(1:lnote)//'p'
  473.           lnote = lnote+1
  474.         end if
  475.         lnote = lnote+1
  476.         write(notex(lnote:lnote),'(i1)')iv
  477.         notex = notex(1:lnote)//notef(nolev(iv,ip))
  478.         lnote = lnote+1
  479.       return
  480.       end
  481.       subroutine beamstrt(notex,lnote,nornb,ihornb)
  482.       include 'pmtex.inc'
  483.       logical figbass
  484.       character*1 notef
  485.       character*25 notex
  486.       real*4 xelsk(16)
  487.       integer ipb(16),nornb(5),ihornb(5,16)
  488.       common /comfig/ ifigdrop(50),iline,figbass
  489.         ibc = ibmcnt(iv)
  490.         n1 = ipl(iv,ibm1(iv,ibc))
  491.         n2 = ipl(iv,ibm2(iv,ibc))
  492.         notex = s//'i'
  493.         lnote = 2
  494.         multb = mult(iv,ibm1(iv,ibc))
  495.         do 1 im = 1 , multb
  496.           notex = notex(1:lnote)//'b'
  497.           lnote = lnote+1
  498. 1       continue
  499.         notex = notex(1:lnote)//ul(iv,ibc)
  500.         lnote = lnote+2
  501. c
  502. c  Put in index for the beam
  503. c
  504.         write(notex(lnote:lnote),'(i1)')iv 
  505.         call SetupB(xelsk,nnb,sumx,sumy,ipb,islope,nolev1,nornb)
  506. c#### Get 'floor' zmin for figures 
  507.         if (figbass .and. iv.eq.1) then
  508.           zmult = 1.2*(multb-1)
  509.           ymin = 100.
  510.           do 3 inb = 1, nnb
  511.             if (fig(ipb(inb)).ne.'x') then
  512.               if (ul(1,ibc) .eq. 'u') then
  513.                 ybot = nolev(1,ipb(inb))
  514.               else
  515.                 ybot = islope/slfac*xelsk(inb)+nolev1-stemlen-zmult
  516.               end if
  517.               ymin = min(ymin,ybot)
  518.             end if
  519. 3         continue
  520.           maxdrop = ncmid(1)-4-ymin+5.01
  521.           ifigdrop(iline) = max(ifigdrop(iline),maxdrop)
  522.         end if
  523. c#### Slope & height analysis done.  Put in name start level and slope
  524.         notex = notex(1:lnote)//notef(nolev1)//'{'
  525.         lnote = lnote+5
  526.         write(notex(lnote-2:lnote),'(i2,a1)')islope,'}'
  527. c#### Compute ornament levels if needed
  528.         if (nornb(iv) .gt. 0) then
  529.           NomOrnLev = ncmid(iv)+5
  530.           iorn = 0
  531.           do 8 inb = 1 , nnb
  532.             if (orn(iv,ipb(inb)) .ne. 'x') then
  533.               iorn = iorn+1
  534.               if (ul(iv,ibc) .eq. 'l') then
  535.                 ihornb(iv,iorn) = max(nolev(iv,ipb(inb))+2,NomOrnLev)
  536.               else
  537.                 ybeam = nolev1+stemlen+islope*xelsk(inb)/slfac-1
  538.      *                  +1.2*(multb-1)
  539.                 ihornb(iv,iorn) = max(ni(ybeam+3.5),NomOrnLev)
  540.               end if
  541.             end if
  542. 8         continue
  543. c#### Henceforth norn(iv) will be a counter.  Be sure to zero it out when
  544. c     beam is finished
  545.           nornb(iv) = 1
  546.         end if
  547.       return
  548.       end
  549.       subroutine beamn1(notex,lnote)
  550.       include 'pmtex.inc'
  551.       character*1 notef
  552.       character*25 notex
  553. c     real*4 xelsk(16)
  554. c     integer ipb(16)
  555.         lnote = 3
  556.         notex = s//'q'//hb(iv,ibmcnt(iv))
  557. c
  558. c  Check for dot
  559. c
  560.         n1 = ipl(iv,ibm1(iv,ibmcnt(iv)))
  561.         nd = nodur(iv,list(2,n1))
  562.         if (nd.ne.0.and.2**log2(int(nd/3.+.1)).ne.int(nd/3.+.1))then
  563.           notex = notex(1:lnote)//'p'
  564.           lnote = lnote+1
  565.         end if
  566.         lnote = lnote+1
  567.         write(notex(lnote:lnote),'(i1)')iv
  568.         notex = notex(1:lnote)//notef(nolev(iv,list(2,n1)))
  569.         lnote = lnote+1
  570.       return
  571.       end        
  572.       subroutine addstr(notex,lnote,sout,lsout)
  573.         character*25 notex
  574.         character*80 sout
  575.         if (lsout+lnote .gt. 72) then
  576.           write(11,'(a)')sout(1:lsout)//'%'
  577.           lsout = 0
  578.         end if 
  579.         if (lsout .gt. 0) then
  580.           sout = sout(1:lsout)//notex(1:lnote)
  581.         else
  582.           sout = notex(1:lnote)
  583.         end if
  584.         lsout = lsout+lnote
  585.       return
  586.       end
  587.       character*1 function notef(nolev)
  588.         if (nolev .le. 26) then
  589.           notef = char(nolev+52)
  590.         else
  591.           notef = char(nolev+70)
  592.         end if
  593.       return
  594.       end
  595.       subroutine notex(notex,lnote)
  596.       include 'pmtex.inc'
  597.       common /comfig/ ifigdrop(50),iline,figbass
  598.       logical figbass
  599.       character*1 ulf,ud
  600.       character*25 notex
  601.       character*1 note,notef 
  602.         nole = nolev(iv,list(2,jn))
  603.         nodu = nodur(iv,list(2,jn)) 
  604.         ud = ulf(1.*(nole-ncmid(iv)))
  605. c####  Check figure level
  606.         if (figbass .and. iv.eq.1 
  607.      *       .and. fig(list(2,jn)).ne.'x') then
  608.           if (ud .eq. 'u') then
  609. c#### Upper stem, fnole (in noleunits) set by notehead
  610.             fnole = nole
  611.           else
  612. c##### Lower stem, fnole set by bottom of stem
  613.             fnole = nole-stemlen
  614.           end if
  615.           zmin = fnole-ncmid(1)+4 
  616.           ifigdrop(iline) = max(ifigdrop(iline),int(4-zmin+.5))
  617.         end if
  618.         if (.not.rest(iv,list(2,jn))) then
  619.           lnote = 5
  620.           note = notef(nole)
  621.           if (int(nodu/3.+.1) .eq. 2**log2(int(nodu/3.+.1))) then
  622.             if (nodu .eq. 3) then
  623.               notex =s//'ccc'//ud//' '//note
  624.               lnote = 7
  625.             else if (nodu .eq. 6) then
  626.               notex =s//'cc'//ud//' '//note
  627.               lnote = 6
  628.             else if (nodu .eq. 12) then
  629.               notex =s//'c'//ud//' '//note
  630.             else if (nodu .eq. 24) then
  631.               notex =s//'q'//ud//' '//note
  632.             else if (nodu .eq. 48) then
  633.               notex =s//'h'//ud//' '//note
  634.             else if (nodu .eq. 96) then
  635.               notex =s//'wh'//' '//note
  636.             end if
  637.           else
  638.             lnote = 6
  639.             if (nodu .eq. 18) then
  640.               notex =s//'c'//ud//'p'//' '//note
  641.             else if (nodu .eq. 36) then
  642.               notex =s//'q'//ud//'p'//' '//note
  643.             else if (nodu .eq. 72) then
  644.               notex =s//'h'//ud//'p'//' '//note
  645.             else if (nodu .eq. 9) then
  646.               notex =s//'c'//ud//'p'//' '//note
  647.               lnote = 7  
  648.             end if
  649.           end if
  650.         else 
  651. c
  652. c  "rest" (real, whole-bar, or accidental gap)
  653. c
  654.           lnote = 3
  655. c
  656. c  First check for whole-bar rest. 
  657. c
  658.           if (acc(iv,list(2,jn)) .eq. 'b') then
  659.             notex = s//'sk'
  660.           else if (acc(iv,list(2,jn)) .eq. 'w') then
  661.             notex = s//'rlap{'//s//'qsk'//s//'pause}'
  662.             lnote = 17
  663. c
  664. c  Now check for accidental gap
  665. c
  666.           else if (acc(iv,list(2,jn)) .eq. 'a') then
  667.             notex = s//'ask'
  668.             lnote = 4
  669.           else if (nodu .eq. 3) then
  670.             notex =s//'hs'
  671.           else if (nodu .eq. 6) then
  672.             notex =s//'qs'
  673.           else if (nodu .eq. 12) then
  674.             notex =s//'ds'
  675.           else if (nodu .eq. 24) then
  676.             notex =s//'qp'
  677.           else if (nodu .eq. 48) then
  678.             notex =s//'hpause'
  679.             lnote = 7
  680.           else if (nodu .eq. 96) then
  681.             notex =s//'pause'
  682.             lnote = 6
  683.           end if
  684.         end if
  685.       return
  686.       end
  687.       subroutine fillbeat(lenbeam,ip1,numbms)
  688.       integer numbms(5)
  689.       include 'pmtex.inc'
  690.       character*1 ulf,hbf 
  691.       in1 = ipl(iv,ip1)
  692.       it1 = list(3,in1)
  693.       it2 = it1+lenbeam
  694.       itend = it1+nodur(iv,ip1)
  695. c### Bounce out if (a) starting time not on an even beat,
  696. c                  (b) rest
  697. c                  (c) a single note fills the beat
  698. c                  (d) too close to the end of the bar
  699. c                  (e) note is quarter or longer
  700.       if (mod(it1,lenbeam).ne.0 .or. rest(iv,ip1) .or. 
  701.      *    nodur(iv,ip1).eq.lenbeam .or. itend.ge.it2 .or.
  702.      *    nodur(iv,ip1).ge.24)     return
  703. c
  704. c In the previous line, "if ... rest" makes beams starting with spaced
  705. c accidentals begin on the note rather than the accidental.
  706. c
  707.       do 1 ip = ip1+1 , nn(iv)
  708. c Add new note
  709.         itend = itend+nodur(iv,ip)
  710. c### Check for real rest or gone past end of potential beam or note >= quarter
  711.         if ((rest(iv,ip).and.acc(iv,ip).ne.'a') .or. itend.gt.it2
  712.      *      .or. nodur(iv,ip).ge.24)  return
  713. c
  714. c If "rest" at this point, it has to be an accidental skip
  715. c
  716.         if (itend.lt.it2.or.(itend.eq.it2.and.rest(iv,ip))) go to 1
  717. c
  718. c  AHA beams
  719. c
  720.         numbms(iv) = numbms(iv) + 1
  721.         ibm1(iv,numbms(iv)) = ip1
  722.         ip2 = ip
  723. c
  724. c  Special check for 4 eighth notes or 3 8ths + 8th rest
  725. c
  726. c       if (mod(it1,48).eq.0 .and. nodur(iv,ip1).eq.12 
  727. c    *      .and. nodur(iv,ip2).eq.12 .and. lenbar.eq.96 .and.
  728. c    *      nn(iv).ge.ip2+2 .and. nodur(iv,ip2+1).eq.12
  729. c    *      .and. nodur(iv,ip2+2).eq.12 .and. .not.rest(iv,ip2+1))
  730. c    *      then
  731. c         if (rest(iv,ip2+2)) then 
  732. c           ip2 = ip2+1
  733. c         else
  734. c           ip2 = ip2+2
  735. c         end if
  736. c       end if
  737.         if (mod(it1,48).eq.0 .and. nodur(iv,ip1).eq.12 
  738.      *      .and. nodur(iv,ip2).eq.12 .and. lenbar.eq.96 .and.
  739.      *      nn(iv).ge.ip2+2 ) then
  740. c#### We have 2 1/8th notes.  Look for third and fourth.
  741.           ixtra = 0
  742.           do 3 jp = ip2+1 , nn(iv)   
  743.             if ((nodur(iv,jp).ne.12.and.acc(iv,jp).ne.'a') .or.
  744.      *             (ixtra.eq.0.and.rest(iv,jp))) go to 4
  745.             if (acc(iv,jp) .eq. 'a') go to 3
  746.             ixtra = ixtra+1
  747.             if (ixtra .eq. 2) then
  748.               if (rest(iv,jp)) then 
  749. c#### 3-1/8th note beam.  Back up to note
  750.                 ip2 = jp-1
  751. 5               if (rest(iv,ip2)) then
  752.                   ip2 = ip2-1
  753.                   go to 5
  754.                 end if
  755.               else
  756.                 ip2 = jp
  757.               end if
  758.               go to 4
  759.             end if
  760. 3         continue
  761.         end if
  762. 4       continue
  763.         ibm2(iv,numbms(iv)) = ip2
  764.         sum = 0.
  765.         elskbm = 0.
  766.         nask = 0 
  767.         do 2 iip = ip1, ip2
  768.           if (rest(iv,iip)) then 
  769.             mult(iv,iip) = 0
  770.             nask = nask + 1
  771.           else
  772.             l2 = log2(int(nodur(iv,iip)/3.+.1))
  773.             sum = sum+nolev(iv,iip)
  774.             mult(iv,iip) = 3-l2
  775.           end if
  776. 2       continue
  777.         ul(iv,numbms(iv)) = ulf(sum/(ip2-ip1+1-nask)-ncmid(iv))
  778.         hb(iv,numbms(iv)) = hbf(sum/(ip2-ip1+1-nask)-ncmid(iv))
  779.         return
  780. 1     continue
  781.       print*,'You should not be here in fillbeat'
  782.       stop
  783.       end
  784.       character*1 function ulf(xnolev)
  785.         if (xnolev .ge. 0.) then
  786.           ulf = 'l'
  787.         else
  788.           ulf = 'u'
  789.         end if
  790.       return
  791.       end
  792.       character*1 function hbf(xnolev)
  793.         if (xnolev .ge. .0) then
  794.           hbf = 'b'
  795.         else
  796.           hbf = 'h'
  797.         end if
  798.       return
  799.       end
  800.       subroutine makeabar()
  801.       include 'pmtex.inc'
  802.       common /combeam/ lenbeam
  803.       integer it(5),cnn(5),istart(20),istop(20),itstart(20),
  804.      *   nspace(20),nindex(20),numbms(5),nornb(5),ihornb(5,16)  
  805.       character*1 notef
  806.       character*80 sout
  807.       character*5 nstart(6)
  808.       character*25 notex
  809.       logical bspend
  810.       data nstart /'notes','Notes','NOtes','NOTes','NOTEs',
  811.      *              'NOTES'/
  812.       do 1 iv = 1 , nv
  813.         if (ibar .gt. 1) then
  814.           nn(iv) = nib(iv,ibar)-nib(iv,ibar-1)
  815.         else
  816.           nn(iv) = nib(iv,ibar)
  817.         end if
  818. 1     continue
  819. c
  820. c initialize list note counter, time(iv), curr. note(iv)
  821. c
  822.       ilnc = 1
  823.       do 4 iv = 1 , nv
  824.         if (nn(iv) .gt. 1) then
  825.           it(iv) = nodur(iv,1)
  826.         else
  827.           it(iv) = 1000
  828.         end if
  829.         cnn(iv) = 1
  830.         list(1,ilnc) = iv
  831.         list(2,ilnc) = 1
  832.         ilnc = ilnc+1
  833. 4     continue
  834. c
  835. c  Build the list
  836. c
  837. 5     continue
  838. c
  839. c  Determine which voice comes next from end of notes done so far.
  840. c  itmin is the earliest ending time of notes done so far
  841. c
  842.       itmin = 1000
  843.       do 6 iv = 1 , nv
  844.         itminn = min(itmin,it(iv))
  845.         if(itminn .lt. itmin) then
  846.           itmin = itminn
  847.           ivnext = iv
  848.         end if
  849. 6     continue
  850.       if (itmin .eq. 1000) go to 7
  851.       list(1,ilnc) = ivnext
  852.       cnn(ivnext) = cnn(ivnext)+1
  853.       list(2,ilnc) = cnn(ivnext) 
  854.       list(3,ilnc) = itmin
  855. c
  856. c  Check if this voice is done
  857. c           
  858.       if (cnn(ivnext) .eq. nn(ivnext)) then
  859.         it(ivnext) = 1000
  860.       else
  861.         it(ivnext) = it(ivnext)+nodur(ivnext,cnn(ivnext)) 
  862.       end if
  863.       ilnc = ilnc+1
  864.       go to 5
  865. 7     continue
  866.       ntot = ilnc-1
  867.       do 8 in = 1 , ntot-1
  868.         list(4,in) = list(3,in+1)-list(3,in)
  869. 8     continue
  870.       list(4,ntot) = nodur(list(1,ntot),list(2,ntot))
  871. c
  872. c  Done w/ list, but for special checks. First, for full-bar rests
  873. c
  874.       do 30 iv = 1 , nv
  875.         if (nodur(iv,1).eq.lenbar.and.rest(iv,1).and.ntot.gt.nv) then
  876. c
  877. c  Find the last list position (in) before the half-bar
  878. c
  879.           do 31 in = 1 , ntot-1
  880.             if (list(3,in+1) .ge. lenbar/2) go to 32
  881. 31        continue
  882.           print*,'Mess-up looking for half-bar'
  883.           stop
  884. 32        itwrest = list(3,in)
  885. c
  886. c  Backup to spot for inserting rest marker, i.e., one to the right of 
  887. c  the first place where either list(1)<iv or list(3)<itwrest 
  888. c
  889.           do 33 iin = in-1 , 1 , -1
  890.             if(list(1,iin).lt.iv.or.list(3,iin).lt.itwrest)go to 34
  891. 33        continue
  892.           print*,'Problem backing up from half bar'
  893. c         stop
  894. 34        infr = iin+1
  895.           call add2list(infr,2,itwrest,lenbar-itwrest,'w',.true.,
  896.      *     ntot,istart,istop,nb)
  897.           nodur(iv,1) = itwrest
  898.           acc(iv,1) = 'b'
  899.         end if
  900. 30    continue  
  901. c
  902. c  A kluged up loop for building note blocks:
  903. c
  904.       ib = 1 
  905.       istart(1) = 1
  906.       nspace(1) = 0
  907.       in = 1 
  908. 9     continue
  909.         if (in .eq. ntot) then
  910.           if (nspace(ib) .eq. 0) nspace(ib)=list(4,in)
  911.           istop(ib) = ntot
  912. c Now we flow out of this if and into block-building      
  913.         else if (nspace(ib) .eq. 0) then
  914. c nspace hasn't been set yet, so 
  915. c and tentatively set:
  916.           nspace(ib) = list(4,in)
  917.           if (nspace(ib) .eq. 0) then
  918.             in=in+1
  919.           else
  920.             istop(ib) = in
  921.           end if
  922.           go to 9
  923.         else if (list(4,in+1) .eq. 0) then
  924. c This is not the last note in the group, so
  925.           in = in+1
  926.           go to 9 
  927.         else if (list(4,in+1) .eq. nspace(ib)) then
  928. c Keep spacing the same, update tentative stop point
  929.           in = in+1
  930.           istop(ib) = in
  931.           go to 9
  932.         end if
  933. c
  934. c At this point istart and istop are good, so on to next block 
  935. c
  936.         itstart(ib) = list(3,istart(ib))
  937.         nindex(ib) = log2(nspace(ib)/2)+1
  938.         if (istop(ib) .eq. ntot) go to 15
  939.         ib = ib+1
  940.         istart(ib) = istop(ib-1)+1
  941.         in = istart(ib)
  942. c
  943. c Set tentative block space for new block
  944. c
  945.         nspace(ib) = list(4,in)
  946.         istop(ib) = in
  947.       go to 9          
  948. 15    continue
  949.       nb = ib
  950. c
  951. c  Now add to list special codes for accidental skips.  This is a loop on
  952. c  in up to ntot, but ntot increases when a skip is added, so loop manually
  953. c  Must bypass this loop if all there are are whole rests.
  954.       if (ntot .eq. nv) go to 40
  955.       in = 2
  956. 39    continue
  957.         jv = list(1,in)
  958.         ip = list(2,in)
  959.         itim = list(3,in)
  960.         if ((acc(jv,ip).eq.'f' .or. acc(jv,ip).eq.'n'
  961.      *      .or. acc(jv,ip).eq.'s') .and. nodur(jv,ip-1).le.6 .and.
  962.      *       ip.ge.2 .and. acc(jv,ip-1).ne.'a') then
  963. c
  964. c  Need accidental skip. Find block # for list position "in".
  965. c
  966.           do 45 ib = 1 , nb
  967.             if (istop(ib) .ge. in) go to 46
  968. 45        continue
  969.           print*,'Got lost looking for ib!!'
  970. 46        continue
  971.           do 42 iv = nv , 1 , -1
  972.             if (iv .eq. jv) then
  973.               iip = ip
  974.               iin = in
  975.               iitim = itim
  976.             else if (nn(iv) .eq. 1) then
  977.               go to 42
  978.             else
  979. c 
  980. c  Find ip# for this voice at this itim !!!  
  981. c
  982.               do 43 iin = 2 , ntot
  983.                 if (list(1,iin).eq.iv.and.list(3,iin).ge.itim)then
  984. c
  985. c  Check if in the same block as the offending accidental
  986. c
  987.                   if (istop(ib) .ge. iin) go to 44
  988. c
  989. c  Note is in next block, so no skip needed.
  990. c
  991.                   go to 42
  992.                 end if
  993. 43            continue
  994. c
  995. c No skip needed, since no new notes after the one in question, so
  996. c
  997.               go to 42
  998. 44            iip = list(2,iin)
  999.               iitim = list(3,iin)
  1000.             end if
  1001.             call add2list(iin,iip,iitim,0,'a',.true.,ntot,
  1002.      *         istart,istop,nb)
  1003. 42        continue
  1004.         end if
  1005.       if (in .eq. ntot) go to 40 
  1006.       in = in+1
  1007.       go to 39
  1008. 40    continue              
  1009. c
  1010. c  Invert the list of places, to make it easier to analyze a voice
  1011. c
  1012.       do 13 in = 1 , ntot
  1013.         ipl(list(1,in),list(2,in)) = in
  1014. 13    continue 
  1015. c
  1016. c Now before writing output, analyze for beams
  1017. c
  1018.       do 20 iv = 1 , nv
  1019.         numbms(iv) = 0
  1020.         do 21 ip = 1 , nn(iv)
  1021.           nbold = numbms(iv)
  1022. c### For each ip beyond the end of the last beam, see if a quarter note
  1023. c### starting here is filled up with notes:
  1024.           if (numbms(iv).eq.0 .or. ip.gt.ibm2(iv,numbms(iv))) then
  1025.             call fillbeat(lenbeam,ip,numbms)
  1026. c### If no new quarter-note beam starts here, check for eighth-note beam
  1027.             if (numbms(iv).eq.nbold .and. acc(iv,ip).ne.'a'.and.
  1028.      *             mod(lenbeam,24).eq.0) then
  1029. c### Starting time
  1030.               ittemp = list(3,ipl(iv,ip))
  1031.               do 22 iip = ip , nn(iv)
  1032.                 call fillbeat(lenbeam/2,iip,numbms)
  1033.                 itendnow = list(3,ipl(iv,iip))+nodur(iv,iip)
  1034.                 if (ittemp+lenbeam.le.itendnow
  1035.      *              .or. mod(itendnow,lenbeam).eq.0) go to 21
  1036. 22            continue
  1037.             end if
  1038.           end if
  1039. 21      continue
  1040. 20    continue
  1041. c
  1042. c  Finally ready to write output
  1043. c 
  1044.       do 25 iv = 1, nv
  1045.         ibmcnt(iv) = 1
  1046.         beamon(iv) = .false.
  1047.         nornb(iv) = 0
  1048. 25    continue        
  1049.       bspend = .false.
  1050.       do 16 ib = 1 , nb
  1051.         sout = s//nstart(nindex(ib)) 
  1052.         lsout = 6
  1053.         do 11 iv = 1 , nv
  1054.           if (iv .gt. 1) call addstr(sepsym,1,sout,lsout)
  1055.           itnow = itstart(ib)
  1056.           do 10 jn = istart(ib), istop(ib)
  1057.             if (list(1,jn) .ne. iv) go to 10
  1058.             ip = list(2,jn)
  1059. 12          if (list(3,jn) .gt. itnow) then   
  1060. c Need skips
  1061.               call addstr(s//'sk',3,sout,lsout)
  1062.               itnow = itnow+nspace(ib)
  1063.               go to 12
  1064.             end if
  1065. c
  1066. c  Skip space for accidentals
  1067. c
  1068.             if (acc(iv,ip) .eq. 'a') then
  1069.               call addstr(s//'ask',4,sout,lsout)
  1070.               go to 10
  1071.             end if
  1072. c
  1073. c  Accidentals
  1074. c
  1075.             if (acc(iv,ip) .eq. 's') then
  1076.               call addstr(s//'xsh '//
  1077.      *             notef(nolev(iv,ip)),6,sout,lsout)
  1078.             else if (acc(iv,ip) .eq. 'f') then
  1079.               call addstr(s//'xfl '//
  1080.      *             notef(nolev(iv,ip)),6,sout,lsout)
  1081.             else if (acc(iv,ip) .eq. 'n') then
  1082.               call addstr(s//'xna '//
  1083.      *             notef(nolev(iv,ip)),6,sout,lsout)
  1084.             end if             
  1085. c####  Check for figure
  1086.             if (iv.eq.1 .and. fig(ip).ne.'x') 
  1087.      *        call putfig(fig(ip),sout,lsout)
  1088. c####  See if a beam starts here
  1089.             if (numbms(iv).gt.0 .and. ibmcnt(iv).le.numbms(iv)
  1090.      *          .and. ibm1(iv,ibmcnt(iv)) .eq. ip) then
  1091.               call beamstrt(notex,lnote,nornb,ihornb)
  1092.               call addstr(notex,lnote,sout,lsout)
  1093.               beamon(iv) = .true.
  1094.               bspend = .true.
  1095.             end if
  1096. c#### Check for ornaments
  1097.             if (orn(iv,ip).ne.'x') then
  1098.               if (nornb(iv) .ne. 0) then
  1099. c#### In a beam, height has already been calculated
  1100.                 ihorn = ihornb(iv,nornb(iv))
  1101.                 nornb(iv) = nornb(iv)+1
  1102.               else if (nolev(iv,ip) .ge. ncmid(iv)) then
  1103. c#### Separate note, lower stem
  1104.                 ihorn = max(ncmid(iv)+5,nolev(iv,ip)+2)
  1105.               else
  1106. c#### Upper beam, must clear the stem
  1107.                 ihorn = max(ncmid(iv)+5,nolev(iv,ip)+2+ni(stemlen-0.5))
  1108.               end if
  1109.               if (orn(iv,ip) .eq. 't') then
  1110.                 notex = s//'pince '
  1111.                 lnote = 8
  1112.               else if (orn(iv,ip) .eq. 'm') then
  1113.                 notex=s//'mordant '
  1114.                 lnote = 10
  1115.               else if (orn(iv,ip) .eq. 's') then
  1116.                 notex=s//'mtr '
  1117.                 lnote = 6
  1118.               end if
  1119.               call addstr(notex(1:lnote-1)//notef(ihorn),lnote,
  1120.      *                   sout,lsout)
  1121.             end if
  1122. c####  Is a beam start pending?
  1123.             if (bspend) then
  1124.               call beamn1(notex,lnote)
  1125.               bspend = .false.
  1126. c####  Is a beam ending?
  1127.             else if (numbms(iv).gt.0 .and. ibmcnt(iv).le.numbms(iv) 
  1128.      *           .and. ibm2(iv,ibmcnt(iv)) .eq. ip) then
  1129.               call beamend(notex,lnote)
  1130.               nornb(iv) = 0
  1131.               ibmcnt(iv) = ibmcnt(iv)+1
  1132.               beamon(iv) = .false.
  1133. c####  Or if we're in the middle of a beam
  1134.             else if (numbms(iv).gt.0 .and. beamon(iv)) then
  1135.               call beamid(notex,lnote)
  1136.             else
  1137. c####  Write a separate note
  1138.               call notex(notex,lnote)
  1139.             end if
  1140.             call addstr(notex,lnote,sout,lsout)
  1141.             itnow = itnow+nspace(ib)
  1142. 10        continue              
  1143. 11      continue
  1144.         call addstr(s//'enotes',7,sout,lsout) 
  1145.         if (lsout .gt. 0) write(11,'(a)')sout(1:lsout)//'%'
  1146. 16    continue           
  1147.       return
  1148.       end
  1149.       subroutine add2list(infr,newip,newstrt,newdur,newacc,newrest,
  1150.      *     ntot,istart,istop,nb)
  1151. c
  1152. c  This inserts into the list a new "note" at location infr.  Inputs vars are
  1153. c     (iv) = voice # (in common)
  1154. c     newip = position in voice, from beginning of bar
  1155. c     newstrt = starting time of new "note"
  1156. c     newdur =  duration
  1157. c     newacc = accidental value
  1158. c     newrest = rest value
  1159. c     
  1160.         include 'pmtex.inc'
  1161.         character*1 newacc
  1162.         logical newrest
  1163.         integer istart(20),istop(20)
  1164. c
  1165. c  Move everything in the list to the right by one spot, and adjust ip
  1166. c    for notes in affected voice.
  1167. c
  1168.         do 34 in = ntot , infr , -1
  1169.           if (list(1,in).eq.iv) list(2,in) = list(2,in)+1
  1170.           do 35 il = 1 , 4
  1171.             list(il,in+1) = list(il,in)
  1172. 35        continue
  1173. 34      continue
  1174. c
  1175. c  Move everything in nodur,rest,acc,nolev to the right by one 
  1176. c
  1177.         do 36 ip = nnl(iv) , newip , -1
  1178.           nodur(iv,ip+1) = nodur(iv,ip)
  1179.           nolev(iv,ip+1) = nolev(iv,ip)
  1180.           acc(iv,ip+1) = acc(iv,ip)
  1181.           orn(iv,ip+1) = orn(iv,ip)
  1182.           rest(iv,ip+1) = rest(iv,ip)
  1183.           if (iv .eq. 1) fig(ip+1) = fig(ip)
  1184. 36      continue
  1185.         nnl(iv) = nnl(iv)+1
  1186.         do 37 iibar = ibar , nbars 
  1187.           nib(iv,iibar) = nib(iv,iibar)+1
  1188. 37      continue
  1189.         ntot = ntot+1
  1190.         nn(iv) = nn(iv)+1
  1191.         nodur(iv,newip) = newdur
  1192.         rest(iv,newip) = newrest
  1193.         acc(iv,newip) = newacc
  1194.         orn(iv,newip) = 'x'
  1195.         if (iv.eq.1) fig(newip) = 'x'
  1196.         list(1,infr) = iv
  1197.         list(2,infr) = newip
  1198.         list(3,infr) = newstrt
  1199.         list(4,infr) = list(3,infr+1)-list(3,infr)
  1200.         list(4,infr-1) = list(3,infr)-list(3,infr-1)
  1201. c
  1202. c Check the note blocks
  1203. c
  1204.         do 38 ib = 1 , nb
  1205.           if (infr .le. istop(ib)) istop(ib) = istop(ib)+1
  1206.           if (infr .lt. istart(ib)) istart(ib) = istart(ib)+1
  1207. 38      continue            
  1208.       return
  1209.       end
  1210.       subroutine putfig(fig,sout,lsout)
  1211.       character*6 fig
  1212.       character*80 sout
  1213.       character*1 ch1,ch2,s
  1214.       character*2 nof,nofa
  1215. c  Platform-independent backslash
  1216.         s = char(92)
  1217.         ic = 1
  1218.         nof = 0
  1219.         nofa = -1
  1220. c
  1221. c  Beginning of loop \/ \/
  1222. c
  1223. 1       ch1 = fig(ic:ic)
  1224.         if (ch1 .eq. ' ') go to 2
  1225. c
  1226. c  Just starting or not yet finished
  1227. c
  1228.         lnof = 1
  1229.         nof = char(nof+48)
  1230.         if (nof .gt. 9) then
  1231.           lnof = 2
  1232.           nof = '1'//char(nof-10+48)
  1233.         end if
  1234.         if (nofa .eq.-1) then
  1235.           lnofa = 2
  1236.           nofa = '-1'
  1237.         else if (nofa .lt. 10) then
  1238.           lnofa = 1
  1239.           nofa = char(nofa+48)
  1240.         else
  1241.           lnofa = 2
  1242.           nofa = '1'//char(nofa+38)
  1243.         end if
  1244.         if (ch1.eq.'#'.or.ch1.eq.'-'.or.ch1.eq.'n') then
  1245.           ic = ic+1
  1246.           ch2 = fig(ic:ic)
  1247.           if (ch2 .eq. ' ') then
  1248. c
  1249. c  Figure is a stand-alone accidental, so must be centered
  1250. c
  1251.             if (ch1 .eq. '#') then
  1252.               call addstr(s//'Figu{'//nofa(1:lnofa)//
  1253.      *          '}{'//s//'smalls@harp}',21+lnofa,sout,lsout)
  1254.             else if (ch1 .eq. '-') then
  1255.               call addstr(s//'Figu{'//nofa(1:lnofa)//
  1256.      *          '}{'//s//'smallf@lat}',20+lnofa,sout,lsout)
  1257.             else if (ch1 .eq. 'n') then
  1258.               call addstr(s//'Figu{'//nofa(1:lnofa)//
  1259.      *                '}{'//s//'smalln@at}',19+lnofa,sout,lsout)
  1260.             end if
  1261.             go to 2
  1262.           else 
  1263. c
  1264. c  Figure is an accidental followed by a number
  1265. c  First put the accidental (offset to the left)
  1266. c
  1267.             if (ch1 .eq. '#') then
  1268.               call addstr(s//'Figu{'//
  1269.      *               nofa(1:lnofa)//'}{'//s//'fsmsh}',
  1270.      *               15+lnofa,sout,lsout)      
  1271.             else if (ch1 .eq. '-') then
  1272.               call addstr(s//'Figu{'//
  1273.      *               nofa(1:lnofa)//'}{'//s//'fsmfl}',
  1274.      *               15+lnofa,sout,lsout)      
  1275.             else if (ch1 .eq. 'n') then
  1276.               call addstr(s//'Figu{'//
  1277.      *               nofa(1:lnofa)//'}{'//s//'fsmna}',
  1278.      *               15+lnofa,sout,lsout)      
  1279.             end if
  1280. c
  1281. c  Now put the number
  1282. c
  1283.             call addstr(s//'Figu{'//nof(1:lnof)//'}{'//ch2//'}',
  1284.      *           10+lnof,sout,lsout)      
  1285.           endif
  1286.         else
  1287. c
  1288. c  Figure is a single number
  1289. c
  1290.           call addstr(s//'Figu{'//nof(1:lnof)//'}{'//ch1//'}',
  1291.      *           10+lnof,sout,lsout)      
  1292.         end if
  1293.         ic = ic+1
  1294.         nof = nof+4
  1295.         nofa = nofa+4  
  1296.         go to 1
  1297. 2     continue
  1298.       return
  1299.       end
  1300.       subroutine topfile
  1301.      *     (basename,lbase,nv,clef,noinst,musicsize,figbass)
  1302.       common /comtop / itopfacteur,ibotfacteur,interfacteur,
  1303.      *   isig,fracindent,imeter,mtrnum,mtrden,iwaskpt,widthpt,height
  1304.       common /comtop/ iname(5)
  1305.       character*24 basename,iname
  1306.       character*40 tstring
  1307.       character*1 clef(5),clefnum,s
  1308.       character*3 rnum(5)
  1309.       logical figbass
  1310.       data rnum /'i  ','ii ','iii','iv ','v  '/
  1311. c Platform-independent backslash
  1312.       s = char(92)
  1313.       write(11,'(a)')'%%%%%%%%%%%%%%%%%'
  1314.       write(11,'(a)')'%'
  1315.       write(11,'(a)')'% '//basename(1:lbase)//'.tex'
  1316.       write(11,'(a)')'%'
  1317.       write(11,'(a)')'%%%%%%%%%%%%%%%%'
  1318.       write(11,'(a)')s//'input musicnft'
  1319.       write(11,'(a)')s//'input musicvbm'
  1320.       write(11,'(a)')s//'input musictex'
  1321.       write(11,'(a)')s//'input musicsty'
  1322.       write(11,'(a)')s//'input musictrp'
  1323.       write(11,'(a)')s//'input pmtex'
  1324.       if (figbass) 
  1325.      *      write(11,'(a)')s//'input '//basename(1:lbase)//'.fig'
  1326.       write(11,'(a)')s//'def'//s//'autol#1#2#3{'
  1327.       if (figbass) 
  1328.      *   write(11,'(a)')s//'global'//s//'advance'//
  1329.      *             s//'sysno by 1'//s//'relax'//s//'fixdrop%'
  1330.       write(11,'(a)')s//'autolines{#1}{#2}{#3}}'
  1331.       write(11,'(a14,i1,a4)')s//'def'//s//
  1332.      *             'ask{'//s//'off{',iwaskpt,'pt}}'
  1333.       write(11,'(a11,i2,a1)')s//'musicsize=',musicsize,'%'
  1334.       write(11,'(a)')s//'tracingstats=2'//s//'relax'
  1335.       write(11,'(a7,i3,a2)')s//'hsize=',int(widthpt+.1),'pt'
  1336.       write(11,'(a7,i3,a2)')s//'vsize=',int(height+.1),'pt'
  1337.       nvp = nv
  1338.       if (noinst .eq. 0) nvp = 1
  1339.       write(11,'(a19,i1,a1)')s//'def'//s//'nbinstruments{',nvp,'}'
  1340.       write(11,'(a16,i2,a1)')s//'def'//s//
  1341.      *                      'topfacteur{',itopfacteur,'}'
  1342.       write(11,'(a19,i2,a1)')
  1343.      *       s//'def'//s//'bottomfacteur{',ibotfacteur,'}'
  1344.       write(11,'(a18,i2,a1)')
  1345.      *       s//'def'//s//'interfacteur{',interfacteur,'}'
  1346.       if (noinst .gt. 0) then
  1347. c
  1348. c  There are nv differenet instruments
  1349. c
  1350.         do 1 iv = 1 , nv
  1351.           write(11,'(a16)')s//'nbportees'//rnum(iv)//'=1%'
  1352.           write(11,'(a)')s//'global'//s//'cleftoks'//rnum(iv)//
  1353.      *                     '={{'//clefnum(clef(iv))//'}{0}{0}{0}}%'
  1354.           do 3 lname = 24 , 2 , -1
  1355.             if (iname(iv)(lname:lname) .ne. ' ') go to 4
  1356. 3         continue
  1357. 4         continue
  1358.           write(11,'(a)')s//'def'//s//'instrument'//rnum(iv)//
  1359.      *         '{'//iname(iv)(1:lname)//'}'
  1360. 1       continue
  1361.       else
  1362. c
  1363. c  There is one inst. with nv voices
  1364. c
  1365.         write(11,'(a12,i1)')s//'nbporteesi=',nv
  1366.         write(*,'(a12,i1)')s//'nbporteesi=',nv
  1367.         tstring = s//'global'//s//'cleftoksi={{0}{0}{0}{0}}'
  1368.         write(*,'(a)')tstring
  1369.         do 2 iv = 1 , nv
  1370.           iposn = 18+3*iv
  1371.           tstring(iposn:iposn) = clefnum(clef(iv))
  1372.           write(*,'(a)')tstring
  1373. 2       continue
  1374.         write(11,'(a)')tstring
  1375.       end if
  1376.       write(11,'(a19,i2,a2)')s//'signaturegenerale{',isig,'}%'
  1377.       write(11,'(a)')s//'def'//s//'gluemaxskip{7pt}%'
  1378.       if (imeter .eq. 0) then
  1379.         write(11,'(a25,i2,a2,i2,a3)')
  1380.      *           s//'generalmeter{'//s//'meterfrac{',
  1381.      *           mtrnum,'}{',mtrden,'}}%'
  1382.       else if (imeter .le. 4) then
  1383.           write(11,'(a21,i1,a2)')
  1384.      *             s//'generalmeter{'//s//'meterN',imeter,'}%'
  1385.       else if (imeter .eq. 5) then
  1386.         write(11,'(a)')s//'generalmeter'//s//'allabreve%'
  1387.       else if (imeter .eq. 6) then
  1388.         write(11,'(a)')s//'generalmeter'//s//'meterC%'
  1389.       end if
  1390.       ipi = fracindent*widthpt+.1
  1391.       if (ipi .lt. 10) then
  1392.         write(11,'(a11,i1,a2)')s//'parindent ',ipi,'pt'
  1393.       else
  1394.         write(11,'(a11,i2,a2)')s//'parindent ',ipi,'pt'
  1395.       end if
  1396.       write(11,'(a)')s//'null'//s//'bigskip'
  1397.       write(11,'(a)')s//'debutmorceau'
  1398.       write(11,'(a)')s//'def'//s//'freqbarno{5}'
  1399.       write(11,'(a)')s//'linesinpage=0'//s//'relax'
  1400.       return
  1401.       end
  1402.       function clefnum(clefname)
  1403.         character*1 clefname,clefnum
  1404.         if (clefname .eq. 'b') then
  1405.           clefnum = '6'
  1406.         else if (clefname .eq. 'a') then
  1407.           clefnum = '3'
  1408.         else if (clefname .eq. 't') then
  1409.           clefnum = '0'
  1410.         end if
  1411.       return
  1412.       end
  1413.       function ni(x)
  1414.         if (x .ge. 0.) then
  1415.           ni = x+0.5001
  1416.         else
  1417.           ni = x-0.5001
  1418.         end if
  1419.       return
  1420.       end
  1421.       subroutine SetupB(xelsk,nnb,sumx,sumy,ipb,islope,nolev1,nornb)
  1422. c
  1423. c The outer combo algorithm
  1424. c
  1425.       include 'pmtex.inc'
  1426.       real*4 xelsk(16),slope(120)
  1427.       integer ipb(16),nornb(5)
  1428.         ibc = ibmcnt(iv)
  1429.         n1 = ipl(iv,ibm1(iv,ibc))
  1430.         n2 = ipl(iv,ibm2(iv,ibc))
  1431.         nornb(iv) = 0
  1432. c
  1433. c Need to figure how many elemskips to the each note. Use the list,
  1434. c counting only those members that have a non-zero interval to next note
  1435. c
  1436.         elsksum = 0.
  1437.         nnb = 0
  1438.         sumx = 0.
  1439.         sumy = 0.
  1440.         do 2 in = n1, n2
  1441.           if (list(1,in).eq.iv .and. acc(iv,list(2,in)).ne.'a') then
  1442.             nnb = nnb+1
  1443.             ipb(nnb) = list(2,in)
  1444.             xelsk(nnb) = elsksum
  1445.             sumx = sumx+elsksum
  1446.             sumy = sumy+nolev(iv,ipb(nnb))
  1447.             if (orn(iv,ipb(nnb)) .ne. 'x') nornb(iv) = nornb(iv)+1
  1448.           end if
  1449.           if (in.lt.n2.and.list(4,in).ne.0) then
  1450.             nindx = log2(list(4,in)/2)+1
  1451.             elsperns = 2.**((nindx-1)/2.)
  1452.             elsksum = elsksum+elsperns
  1453.           end if
  1454. 2       continue
  1455.         nsc = 0
  1456.         do 5 inb = 1 , nnb-1
  1457.           do 5 jnb = inb+1 , nnb
  1458.             nsc = nsc+1
  1459.             slope(nsc) = (nolev(iv,ipb(jnb))-nolev(iv,ipb(inb)))/
  1460.      *                   (xelsk(jnb)-xelsk(inb))
  1461.             if (abs(slope(nsc)) .lt. 1.e-4) then
  1462.               nsc = nsc+1
  1463.               slope(nsc) = slope(nsc-1)
  1464.               nsc = nsc+1
  1465.               slope(nsc) = slope(nsc-1)
  1466.             end if
  1467. 5       continue
  1468. c       write(*,'(a7,1x,9f8.2/(8x,9f8.2))')'slopes:',(slope(i),i=1,nsc)
  1469.         if (nsc .eq. 1) then
  1470.           smed = slope(1)
  1471.           go to 6
  1472.         end if
  1473.         nscmid = nsc/2+1
  1474.         do 7 i = 1 , nscmid
  1475.           do 7 j = i+1 , nsc
  1476.             if (slope(j) .lt. slope(i)) then
  1477.               t = slope(j)
  1478.               slope(j) = slope(i)
  1479.               slope(i) = t
  1480.             end if
  1481. 7       continue
  1482.         smed = slope(nscmid)
  1483.         if (nsc.eq.2*(nsc/2).and.
  1484.      *   abs(slope(nscmid-1)).lt.abs(slope(nscmid)))smed=slope(nscmid-1)
  1485. 6       continue
  1486.         islope = ni(smed*slfac)
  1487.         if (iabs(islope) .gt. 9) islope = isign(9,islope)
  1488. c       beta = (sumy-smed*sumx)/nnb
  1489.         beta = (sumy-islope/slfac*sumx)/nnb
  1490.         nolev1 = beta+.5
  1491. c#### Check if any stems are too short
  1492.         smin = 100.
  1493.         iul = -1
  1494.         if (ul(iv,ibc) .eq. 'u') iul = 1
  1495.         ssq = 0.
  1496.         syb = 0.
  1497.         do 4 inb = 1 , nnb
  1498.           ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac
  1499.           syb = syb+ybeam
  1500.           ynote = nolev(iv,ipb(inb))
  1501.           off = ybeam-ynote
  1502.           if (inb .eq. 1) then
  1503.             off1 = off
  1504.           else if (inb .eq. nnb) then
  1505.             off2 = off
  1506.           end if
  1507.           ssq = ssq+off*off
  1508.           smin = min(smin,iul*off)
  1509. 4       continue
  1510.         dnolev = 0.
  1511.         if (smin .lt. stemmin) then
  1512.           deficit = stemmin-smin
  1513.           nolevo = nolev1
  1514.           nolev1 = ni(nolev1+iul*deficit)
  1515.           dnolev = nolev1-nolevo
  1516.           off1 = off1+dnolev
  1517.           off2 = off2+dnolev
  1518.         end if
  1519.         ssq = ssq+2*dnolev*(syb-sumy)+dnolev**2
  1520.         if (sqrt(ssq/nnb) .gt. stemmax .and. 
  1521.      *    (abs(off1).lt.stemmax .or. abs(off2).lt.stemmax)) then
  1522. c#### The final check before switching is that first and last stems aren't
  1523. c     both excessive.
  1524.           call SetupB2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1)
  1525.         end if
  1526.       return
  1527.       end
  1528.       subroutine SetupB2(xelsk,nnb,sumx,sumy,ipb,islope,nolev1)
  1529. c
  1530. c The MEAN SQUARE slope algorithm
  1531. c
  1532.       include 'pmtex.inc'
  1533.       real*4 xelsk(16)
  1534.       integer ipb(16)
  1535.         ibc = ibmcnt(iv)
  1536.         n1 = ipl(iv,ibm1(iv,ibc))
  1537.         n2 = ipl(iv,ibm2(iv,ibc))
  1538. c
  1539. c Need to figure how many elemskips to the each note. Use the list,
  1540. c counting only those members that have a non-zero interval to next note
  1541. c
  1542.         elsksum = 0.
  1543.         nnb = 0
  1544.         ipb(1) = n1
  1545.         sumx = 0.
  1546.         sumxx = 0.
  1547.         sumy = 0.
  1548.         sumxy = 0.
  1549.         do 2 in = n1, n2
  1550.           if (list(1,in).eq.iv .and. acc(iv,list(2,in)).ne.'a') then
  1551.             nnb = nnb+1
  1552.             ipb(nnb) = list(2,in)
  1553.             xelsk(nnb) = elsksum
  1554.             sumx = sumx+elsksum
  1555.             sumxx = sumxx+elsksum*elsksum 
  1556.             y = nolev(iv,list(2,in))
  1557.             sumy = sumy+y
  1558.             sumxy = sumxy+elsksum*y
  1559.           end if
  1560.           if (in.lt.n2.and.list(4,in).ne.0) then
  1561.             nindx = log2(list(4,in)/2)+1
  1562.             elsperns = 2.**((nindx-1)/2.)
  1563.             elsksum = elsksum+elsperns
  1564.           end if
  1565. 2       continue
  1566.         delta = nnb*sumxx-sumx*sumx
  1567.         em = (nnb*sumxy-sumx*sumy)/delta
  1568.         islope = ni(em*slfac)
  1569.         if (iabs(islope) .gt. 9) then
  1570.           islope = isign(9,islope)
  1571.           beta = (sumy-islope/slfac*sumx)/nnb
  1572.         else
  1573.           beta = (sumy*sumxx-sumx*sumxy)/delta
  1574.         end if
  1575.         nolev1 = beta+.5
  1576. c#### Check if any stems are too short
  1577.         smin = 100.
  1578.         iul = -1
  1579.         if (ul(iv,ibc) .eq. 'u') iul = 1
  1580.         do 4 inb = 1 , nnb
  1581.           ybeam = nolev1+iul*stemlen+islope*xelsk(inb)/slfac
  1582.           ynote = nolev(iv,ipb(inb))
  1583.           smin = min(smin,iul*(ybeam-ynote))
  1584. 4       continue
  1585.         if (smin .lt. stemmin) then
  1586.           deficit = stemmin-smin
  1587.           nolevo = nolev1
  1588.           nolev1 = ni(nolev1+iul*deficit)
  1589.         end if
  1590.       return
  1591.       end  
  1592.