summaryrefslogtreecommitdiff
path: root/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for
diff options
context:
space:
mode:
Diffstat (limited to 'Build/source/utils/pmx/pmx-2.6.18/scor2prt.for')
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/scor2prt.for1620
1 files changed, 1620 insertions, 0 deletions
diff --git a/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for
new file mode 100644
index 00000000000..99fe18e4cab
--- /dev/null
+++ b/Build/source/utils/pmx/pmx-2.6.18/scor2prt.for
@@ -0,0 +1,1620 @@
+cccccccccccccccccccccccccc
+cc
+cc scor2prt 7/24/11 for PMX 2.615
+cccccccccccccccccccccccccc
+c This program, developed by Don Simons (dsimons@roadrunner.com), is
+c part of the PMX distribution, PMX is a preprocessor for MusiXTeX. In concert
+c with MusiXTeX and TeX, the purpose of PMX is to allow the user to create
+c high-quality typeset musical scores by including a sequence of PMX commands
+c in an ASCII input file. Scor2prt is an auxiliary program that creates PMX
+c input files for individual parts from the PMX input file for the score.
+c
+c This program is free software: you can redistribute it and/or modify
+c it under the terms of the GNU General Public License as published by
+c the Free Software Foundation, either version 3 of the License, or
+c (at your option) any later version.
+c
+c This program is distributed in the hope that it will be useful,
+c but WITHOUT ANY WARRANTY; without even the implied warranty of
+c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+c GNU General Public License for more details.
+c
+c You should have received a copy of the GNU General Public License
+c along with this program. If not, see <http://www.gnu.org/licenses/>.
+c
+c
+c 7/18/11
+c Start to fix up for AS..., also Ki was done a little earlier.
+c 7/5/10
+c Modify Manual to explain extended hex numbering for part-specific comments
+c 5/16/10
+c Extend part-specific comments for up to 24 parts (subroutine chkcom)
+c Allow files 11-34 for parts
+c Change file 30 to 40
+c 6/1/08 es2p
+c noimax = 24
+c
+c To do
+c Override fracindent, musicsize?
+c Deal with midbar R?
+c 2/29/04
+c Check for special character being in quoted string.
+c 10/20/02 PMX 2.407
+c Interpret AN[n]"[used-defined-part-file-name]"
+c 1/21/02
+c Deals with rm in multiple parts.
+c s2p15
+c Get right non-tex index even if there's "\" inside D"..."
+c s2p14
+c 10/29/00 fix transfer to parts of negative mtrdnp
+c 4/29/00 screen for "%%" followed by "T"
+c Restore change from "Version 2.1a, 21 Dec"
+c s2p13
+c Allow whole-bar double-whole rests.
+c Bypass MIDI commands "I..." achar(10)="I"
+c s2p12
+c Let %ablabla ... %cblabla represent pmx input for parts 10-12. But %?blabla
+c only taken as such if ? represents a hex digit .le. noinst, otherwise it's
+c a simple comment. This lessens incompatibility.
+c In subroutine mbrest, properly open parts 10-12 if needed
+c s2p11
+c Ignore leading blanks
+c Fix undefined linelength in mbrest at very end of comments.
+c s2p10
+c Fix non-transfer of P..c" "
+c Allow "%%" and "%"n anywhere
+c Version 1.43
+c Fix bug with P in TeX string.
+c Ignore shifted whole-bar rests when consolidating whole-bar rests
+c Copy type 4 TeX into all parts.
+c Deal with XB and XP.
+c Permit transfer of blank line into parts
+c Change staves/inst in 'M' command.
+c Arbitrary staves/inst.
+c Recognize m1/2/3/4 syntax.
+c Enable comment and one-voice syntax in instrument names
+c
+c Changes since 1.1
+c Deal with saved macros.
+c Revise setup readin, to admit comments.
+c Do not copy 'X' into parts
+c
+cccccccccccccccccccccccccccccccccccccccccccccccc
+ parameter (noimax=24)
+ common /all/ noinow,iorig(noimax),noinst,insetup,replacing,
+ * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow
+ integer*4 ludpfn(noimax)
+ character*1 sq,achar(10)
+ character*2 termsym
+ character*27 jobname,infileq
+ character*128 instrum(noimax),udpfnq(noimax)
+ character*128 line,holdln,templine
+ logical termrpt,isachar,frstln,oneof2,botv,clefpend,fexist,
+ * insetup,replacing,gotname,yesodd
+ data achar /'P','m','V','R','A','h','w','K','M','I'/
+ clefpend = .false.
+ insetup = .true.
+ replacing = .false.
+ frstln = .true.
+ lenhold = 0
+ sq = char(92)
+ print*,'This is scor2prt for PMX 2.615, 24 July 2011'
+ numargs = iargc()
+ if (numargs .eq. 0) then
+ print*,'You could have entered a jobname on the command line,'
+ print*,' but you may enter one now:'
+ read(*,'(a)')jobname
+ numargs = 1
+ else
+c call getarg(1,jobname,idum) ! May need to replace this w/ next line
+ call getarg(1,jobname)
+ end if
+ ljob = lenstr(jobname,27)
+ if (ljob .eq. 0) then
+ print*,'No was jobname entered. Restart and try again.'
+ stop
+ end if
+c
+c Strip ".pmx" if necessary
+c
+ ndxpmx = max(index(jobname,'.pmx'),index(jobname,'.PMX'))
+ if (ndxpmx .gt. 0) then
+ jobname = jobname(1:ndxpmx-1)
+ ljob = ljob-4
+ end if
+c
+c Check for existence of input file
+c
+ infileq = jobname(1:ljob)//'.pmx'
+ inquire(file=infileq,EXIST=fexist)
+ if (.not.fexist) then
+ print*,'Cannot find file '//infileq
+ stop
+ end if
+ open(10,file=jobname(1:ljob)//'.pmx')
+c
+c Open all instrument files now for allparts stuff. Later disgard those >nv
+c
+ do 19 iv = 1 , noimax
+ iorig(iv) = iv
+ open(10+iv,status='SCRATCH')
+ ludpfn(iv) = 0
+19 continue
+ read(10,'(a)')line
+ call chkcom(line)
+ if (line(1:3) .eq. '---') then
+ call allparts(line,128)
+31 read(10,'(a)')line
+ if (line(1:3) .ne. '---') then
+ call allparts(line,128)
+ go to 31
+ end if
+ call allparts(line,128)
+ read(10,'(a)')line
+ call chkcom(line)
+ end if
+ iccount = 0
+ nv = readin(line,iccount,1)+.1
+ noinst = readin(line,iccount,2)+.1
+ if (noinst .gt. 0) then
+ nvi(1) = nv-noinst+1
+ else
+ noinst = 1-noinst
+ do 21 iinst = 1 , noinst
+ nvi(iinst) = readin(line,iccount,-1)+.1
+21 continue
+ end if
+ noinow = noinst
+ insnow = 1
+c
+c ivlast is last iv in current inst. instnum(iv) is iinst for current voice.
+c
+ ivlast = nvi(1)
+ do 22 iv = 1 , nv
+ instnum(iv) = insnow
+ if (iv .eq. ivlast) then
+ if (iv .lt. nv) botv(iv+1) = .true.
+c
+c The previous stmt will set botv true only for bot voice of iinst>1. It is
+c used when writing termrpts, but the one in voice one is handled differently,
+c so botv(1) is left .false.
+c
+ if (insnow .lt. noinst) then
+ insnow = insnow+1
+ ivlast = ivlast+nvi(insnow)
+ end if
+ end if
+22 continue
+ mtrnuml = readin(line,iccount,0)+.1
+ mtrdenl = readin(line,iccount,0)+.1
+ mtrnmp = readin(line,iccount,0)+.1
+ mtrdnp = readin(line,iccount,0)+.1
+ xmtrnum0 = readin(line,iccount,0)
+ isig = readin(line,iccount,0)+.1
+ npages = readin(line,iccount,3)+.1
+ nsyst = readin(line,iccount,0)+.1
+ musicsize = readin(line,iccount,4)+.1
+ fracindent = readin(line,iccount,5)
+ 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
+c
+c Must leave insetup=.true. else could bypass ALL instrument names.
+c
+ read(10,'(a)')line
+ call chkcom(line)
+ backspace(10)
+c
+c Normally this puts pointer at start of line with 1st inst name
+c Check if prior line was "%%"
+c
+ backspace(10)
+ read(10,'(a)')line
+ if (line(1:2) .eq. '%%') backspace(10)
+ do 14 iv = 1 , noinst
+ gotname = .false.
+16 read(10,'(a)') instrum(iv)
+ if (instrum(iv)(1:2) .eq. '%%') then
+ read(10,'(a)')line
+ go to 16
+ else if (instrum(iv)(1:1) .eq. '%') then
+ ivq = ichar(instrum(iv)(2:2))-48
+ if (ivq.ne.iv) then
+c
+c It's really a comment. Copy to parts, then get another trial name.
+c
+ call allparts(instrum(iv),128)
+ go to 16
+ else
+ line = instrum(iv)(3:)
+ instrum(iv) = line
+ gotname = .true.
+ end if
+ else
+ gotname = .true.
+ end if
+cc
+cc The following checks for macro that write original C-clef as part of
+cc instrument name. See pmx.tex
+cc
+c if (index(instrum(iv),'namewpc') .eq. 0) then
+c write(10+iv,'(a)')' '
+c else
+c inm1 = index(instrum(iv),'{')+1
+c inm2 = index(instrum(iv),'}')-1
+c read(instrum(iv)(inm2+2:inm2+8),'(i1,4x,2i1)')ilev,iy1,iy2
+c write(10+iv,'(a)')sq//'namewpc{}'//char(ilev+48)//'{20}'//
+c * char(iy1+49)//char(iy2+49)
+c instrum(iv) = instrum(iv)(inm1:inm2)
+c end if
+ if (.not.gotname) then
+ print*,'You must provide a replacement instrument name'
+ stop
+ end if
+ write(10+iv,'(a)')' '
+14 continue
+ replacing = .false.
+ nvnow = nv
+c
+c Clef string: Note insetup is still T, so "%%" will be treated specially
+c
+ read(10,'(a)')line
+ call chkcom(line)
+ if (replacing) then
+c
+c If here, we have next line after "%%", containing score's clef string
+c Assume all clefs are handled with instrument comments.
+c
+ read(10,'(a)')line
+ call chkcom(line)
+ backspace(10)
+ else
+c
+c If here, line has the clef string in it. Handle the old way
+c
+ kvstart = 1
+ kvend = nvi(1)
+ do 2 inst = 1 , noinst
+ write(10+inst,'(a'//char(48+nvi(inst))//')')
+ * line(kvstart:kvend)
+ if (inst .lt. noinst) then
+ kvstart = kvend+1
+ kvend = kvstart+nvi(inst+1)-1
+ end if
+2 continue
+ end if
+ replacing = .false.
+ insetup = .false.
+c
+c *****NOTE*****This comment applies to stuff done earlier!
+c Before starting the big loop, copy initial instnum and staffnum stuff
+c into working values. Latter may change if noinst changes. Also make
+c list of current inst nums relative to original ones. In addition to those
+c below, must redo instnum(iv) and botv(iv) when we change noinst.
+c
+c Path string: ASSUME THIS WILL NEVER BE ALTERED IN PARTS!
+c
+18 read(10,'(a)') line
+ if (line(1:1) .eq. '%') then
+ call allparts(line,128)
+ go to 18
+ end if
+ 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
+ lenline = lenstr(line,128)
+ if (lenline .eq. 0) go to 4
+ call zapbl(line,128)
+ call chkcom(line)
+ lenline = lenstr(line,128)
+ if (lenline .eq. 0) go to 4
+ 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) then
+ call allparts(line,128)
+ go to 4
+ else if (index('hl',line(1:1)).gt.0 .and.
+ * index(' +-',line(2:2)) .gt. 0) then
+ call allparts(line,128)
+ read(10,'(a)')line
+ call allparts(line,128)
+ go to 4
+ else if (iv .eq. 1) then
+ do 5 ia = 1 , 10
+24 continue
+ idxa = ntindex(line,achar(ia))
+ isachar = idxa .gt. 0
+ if (idxa.gt.1) isachar = line(idxa-1:idxa-1).eq.' '
+c
+c 1 2 3 4 5 6 7 8 9 10
+c data achar /'P','m','V','R','A','h','w','K','M','I'/
+c
+ if (ia .eq. 9) isachar =
+ * isachar .and. line(idxa+1:idxa+1).eq.'S'
+ if (isachar) then
+c
+c Check whether character is inside a quoted string by counting
+c how many quotes precede it in the line
+c
+
+ call OddQuotesBefore(line,idxa,yesodd)
+ if (yesodd) isachar=.false.
+ end if
+ if (isachar) 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,MS, or w"'
+ print*,
+ * 'Send files to Dr. Don at dsimons at roadrunner dot com'
+ stop 1
+7 continue
+c
+c Next blank is at position ib. Later, if ia=1, must check for Pc" " ;
+c i.e., look for '"' between P and blank
+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
+c
+c If any subsequent character on this line is neither blank nor "/", get out
+c
+ if (index(' /',line(ic:ic)) .eq. 0) go to 9
+ if (line(ic:ic) .eq. '/') then
+ termrpt = .true.
+ termsym = line(ib-2:ib-1)
+c
+c Process the line as if there were no "R"
+c
+ go to 10
+ end if
+8 continue
+c
+c +++ 060812
+c If here, all chars after "R" symbol are blanks, so process the line normally,
+c but only IF next line is not the M-Tx line " /"
+c
+ read(10,'(a)')templine
+ if (templine(1:2) .ne. ' /') then
+ backspace(10) ! and flow out
+ else
+c
+c We have the M-Tx case where one line ends with R? and next is " /". Add / to the line,
+c and proceed as above
+c
+ line = line(1:ib)//'/'
+ lenline = lenline+2
+ termrpt = .true.
+ termsym = line(ib-2:ib-1)
+ go to 10
+ end if
+c +++ 060812
+c
+ else if (ia .eq. 1) then
+ idxq = ntindex(line,'"')
+ if (idxq.gt.idxa .and. idxq.lt.ib) then
+c
+c Quote is between P and next blank. Find 2nd quote, starting at the blank.
+c
+ idxq2 = ib-1+ntindex(line,'"')
+ if (idxq.eq.0 .or. line(idxq2+1:idxq2+1).ne.' ') then
+ print*
+ print*,'Error copying P with quotes, idxq2:',idxq2
+ print*,line(1:60)
+ stop 1
+ end if
+ ib = idxq2+1
+ end if
+c
+c Do not transfer P into parts.
+c
+ go to 12
+ else if (ia .eq. 9) then
+c
+c Start Saving a macro. After leaving here, a symbol will be sent to all parts,
+c If all on this line, set ib to end and exit normally.
+c
+ ndxm = index(line(ib+1:128),'M')
+ if (ndxm.gt.0 .and. line(ib+ndxm-1:ib+ndxm-1).eq.' ') then
+c
+c Macro ends on this line
+c
+ ib = ib+ndxm+1
+ else
+c
+c Save leading part of current line
+c
+ lenhold = idxa-1
+ if (lenhold .gt. 0) holdln = line(1:lenhold)
+c
+c Transfer rest of line
+c
+ call allparts(line(idxa:128),129-idxa)
+c
+c Read next line
+c
+20 read(10,'(a)')line
+c
+c Check for comment, transfer and loop if so
+c
+c if (line(1:1) .eq.'%') then
+23 if (line(1:1) .eq.'%') then
+c call allparts(line,128)
+c go to 20
+ call chkcom(line)
+ go to 23
+ end if
+c
+c Look for terminal ' M'
+c
+ if (line(1:1) .eq. 'M') then
+ ndxm = 1
+ else
+ ndxm = index(line,' M')
+ if (ndxm .gt. 0) ndxm = ndxm+1
+ end if
+ if (ndxm .gt. 0) then
+c
+c Set parameters, exit normally (but later check for leading part of 1st line
+c
+ idxa = 1
+ ib = ndxm+1
+ else
+c
+c No "M", transfer entire line, loop
+c
+ call allparts(line,128)
+ go to 20
+ end if
+ end if
+ else if (ia .eq. 10) then
+c
+c Do not transfer MIDI command into parts
+c
+ go to 12
+ else if (ia .eq. 5) then
+c
+c First check for "AS", but S may come after other "A" options
+c
+ idxS = index(line(idxa+1:ib),'S')
+ if (idxS .gt. 0) then
+c
+c Get rid of the string. First check if that's all there is in A.
+c
+ if (ib-idxa .eq. nv+2) go to 12
+ line = line(1:idxa+idxS-1)//line(idxa+idxS+nv+1:ib)
+ end if
+c
+c Check for user-defined part file name. Must start in column 1 and have
+c AN[n]"userfilename".
+c idxa is position of "A"
+c ib is position of the next blank after "A"
+c Don't allow any blanks in user
+c
+ if (line(idxa+1:idxa+1) .ne. 'N') go to 9 ! bail out
+ if (idxa .ne. 1) then
+ print*
+ print*,
+ * 'You entered "AN..." somewhere beyond first column; stopping.'
+ stop 1
+ end if
+c
+c pmxa already checked for valid one- or 2-digit number, so get it
+c
+ if (line(4:4) .eq. '"') then
+c
+c Single digit instrument number
+c
+ read(line(3:3),'(i1)')iudpfn
+ idxstartname = 5
+ else
+ read(line(3:4),'(i2)')iudpfn
+ idxstartname = 6
+ end if
+ ludpfn(iudpfn) = index(line(idxstartname:128),'"')-1
+ if (ludpfn(iudpfn) .lt. 0) then
+ print*
+ print*,'User-defined part file name must be in quotes'
+ stop 1
+ end if
+ idxendname = idxstartname+ludpfn(iudpfn)-1
+ udpfnq(iudpfn) = line(idxstartname:idxendname)
+c
+c Get a new line!
+c
+ go to 4
+ else if (ia .eq. 8) then
+c
+c Key change/transposition.
+c If not instrument specific, copy to all parts
+c
+ if (line(idxa+1:idxa+1).ne.'i') go to 9
+c
+c Instrument-wise key/transposition(s): Ki[nn][+/-][dd}[+/-][dd]...
+c
+ ibb = idxa+2 ! Starts on digit after 'i'
+40 continue
+ read(line(ibb:ibb),'(i1)')iiinst ! 1st digit of iinst
+ itemp = (index('01234567890',line(ibb+1:ibb+1)))
+ if (itemp.gt.0) then
+ ibb = ibb+1
+ iiinst = 10*iiinst+itemp-1
+ end if
+ ibb = ibb+1 ! now at first +/-. Need end of 2nd number
+ itemp = index(line(ibb+1:ib),'i') ! Rel pos'n of next 'i' or 0
+ if (itemp .gt. 0) then
+ iend = ibb+itemp-1
+ else
+ iend = ib-1
+ end if
+ write(10+iorig(iiinst),'(a)')'Ki1'//line(ibb:iend)
+ if (itemp .gt. 0) then
+ ibb = iend+2
+ go to 40
+ end if
+ go to 12 ! Remove K command from string, go to next ia
+ 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
+ lenline = lenstr(line,128)
+c
+c Loop if only blanks are left
+c
+ if (lenline .eq. 0) go to 4
+c
+c Must check for multiple "I" commands, so go to just after start of ia loop
+c
+ if (ia .eq. 10) go to 24
+c
+c Tack on front part from 1st line of saved macro
+c
+ if (lenhold .gt. 0) then
+ line = holdln(1:lenhold)//' '//line(1:lenline)
+ lenhold = 0
+ end if
+ end if
+5 continue
+ end if
+c
+c Now a special loop to deal with 'X'. If it was %[n]X..., will have been
+c copied into part [n] already. If no "B" or "P", remove. If "P", just
+c remove the "P" so pmxa/b will process. If "B". do nothing.
+c
+10 continue
+ nchk = 1
+13 ntinx = nchk-1+ntindex(line(nchk:),'X')
+ if (ntinx .gt. nchk-1) then
+c
+c There is a non-TeX 'X' at ntinx. Loop if neither 1st nor after a blank.
+c
+ if (ntinx.gt.1) then
+ if (line(ntinx-1:ntinx-1).ne.' ') then
+c
+c The X is not 1st char of PMX command. Advance starting point, loop.
+c
+ nchk = ntinx+1
+ go to 13
+ end if
+ end if
+c
+c We now know the X at ntinx starts a PMX command. Find next blank
+c
+ ib = ntinx+index(line(ntinx+1:),' ')
+c
+c There must be a blank to right of "X", so ib>ntinx
+c
+c locp = nchk-1+index(line(nchk:ib),'P')
+ locp = ntinx+index(line(ntinx+1:ib),'P')
+c
+c Did not need to use ntindex because we already know bounds of PMX command.
+c
+c if (locp .gt. nchk-1) then
+ if (locp .gt. ntinx) then
+c
+c Strip out the 'P'
+c
+ templine = line(1:locp-1)
+ line = templine(1:locp-1)//line(locp+1:lenline)
+ lenline = lenline-1
+ ib = ib-1
+ end if
+ if (index(line(ntinx:ib),':').gt.0 .or.
+ * index(line(ntinx:ib),'S').gt.0 .or.
+ * index(line(ntinx:ib),'B').gt.0 .or. locp.gt.ntinx) then
+c
+c The X command is a shift, "Both", or "Part". Do not remove.
+c
+ nchk = ib+1
+ go to 13
+ end if
+c
+c Remove the X command.
+c
+ if (ntinx .eq. 1) then
+ if (ib .lt. lenline) then
+ line = line(ib+1:lenline)
+ else
+c
+c line contains ONLY the "X" command, so get a new line
+c
+ go to 4
+ end if
+ else
+ templine = line(1:ntinx-1)
+ if (ib .lt. lenline) then
+ line = templine(1:ntinx-1)//line(ib+1:lenline)
+ else
+ line = templine(1:ntinx-1)
+ end if
+ end if
+c
+c Recompute lenline
+c
+ lenline = lenstr(line,128)
+c
+c Resume checking after location of removed command.
+c
+ nchk = ntinx
+ go to 13
+ end if
+c
+c End of loop for X-checks
+c
+ oneof2 = ntindex(line,'//') .gt. 0
+ if (termrpt .and. botv(iv) .and. frstln .and.
+ * line(lenline:lenline).eq.'/') then
+c
+c Must add a terminal repeat before the slash
+c
+ if (oneof2) lenline = lenline-1
+ if (lenline.gt.1) write(10+iorig(iinst),'(a)')line(1:lenline-1)
+ if (.not. oneof2) then
+ line = termsym//' /'
+ lenline = 4
+ else
+ line = termsym//' //'
+ lenline = 5
+ end if
+ end if
+ if (termrpt .and. frstln .and. line(lenline:lenline).eq.'/' .and.
+ * iv.eq.nvnow) termrpt = .false.
+ write(10+iorig(iinst),'(a)')line(1:lenline)
+ if (oneof2) then
+ frstln = .false.
+ else if (.not.frstln) then
+ frstln = .true.
+ end if
+c if (ntindex(line,'/').gt.0 .and. index(line,'//').eq.0) then
+ if (ntindex(line,'/').gt.0 .and. ntindex(line,'//').eq.0) then
+ iv = 1+mod(iv,nvnow)
+ iinst = instnum(iv)
+ end if
+ go to 4
+999 continue
+ close(10)
+c
+c In the mbrest checks, must run through ALL noinst files (not just noinow)
+c
+ do 11 iinst = 1 , noinst
+ccc+++
+cc
+cc Temporarily transfer entire scratch file to real file
+cc
+c rewind(10+iinst)
+c open(40,file='s2pout'//char(48+iinst)//'.pmx')
+c do 50 m = 1 , 10000
+c read(10+iinst,'(a)',end=51)line
+c lenline = lenstr(line,128)
+c if (lenline .ge. 1) then
+c write(40,'(a)')line(1:lenline)
+c else
+c write(40,'(a)')' '
+c end if
+c50 continue
+c51 continue
+c close(40)
+ccc+++
+ if (nvi(iinst) .eq. 1) then
+ call mbrests(iinst,jobname,ljob,ludpfn(iinst),udpfnq(iinst))
+ else
+c
+c Send a signal with ljob to bypass most mbrest processing
+c
+ call mbrests(iinst,jobname,-ljob,ludpfn(iinst),udpfnq(iinst))
+ 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)
+ parameter (noimax=24)
+ character*(*) string
+ common /all/ noinow,iorig(noimax),noinst,insetup,replacing,
+ * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow
+ logical insetup,replacing,botv
+ len = lenstr(string,n)
+ if (len .eq. 0) then
+ len = 1
+ string = ' '
+ end if
+ do 1 iinst = 1 , noinow
+ write(10+iorig(iinst),'(a)')string(1:len)
+1 continue
+ return
+ end
+ subroutine mbrests(iv,jobname,ljob,ludpfn,udpfnq)
+ character*128 line(50),line1,udpfnq
+ character*80 sym
+ character*12 jobname
+ character*3 wbrsym(2)
+ character*2 partq
+ character*1 sq
+ logical wbrest,alldone,rpfirst,newmtr,type4
+ type4 = .false.
+ sq = char(92)
+ alldone = .false.
+ rewind(10+iv)
+c open(20,file=jobname(1:abs(ljob))//char(48+iv)//'.pmx')
+ if (iv .lt. 10) then
+ partq(1:1) = char(48+iv)
+ lpart = 1
+c
+c 5/16/10 Fix for >20 parts
+c
+c else
+c partq = '1'//char(38+iv)
+c lpart = 2
+ else
+ lpart = 2
+ if (iv .lt. 20) then
+ partq = '1'//char(38+iv)
+ else
+ partq = '2'//char(28+iv)
+ end if
+ end if
+c if (ludpfn .eq. 0) then
+ open(40,file=jobname(1:abs(ljob))//partq(1:lpart)//'.pmx')
+c else
+c open(30,file=udpfnq(1:ludpfn)//'.pmx')
+c end if
+ do 10 i = 1 , 10000
+ read(10+iv,'(a)')line(1)
+ if (line(1)(1:1).eq.'%' .or. line(1)(1:3).eq.'---'
+ * .or. type4) then
+ len = lenstr(line(1),128)
+ if (len .gt. 0) then
+ write(40,'(a)')line(1)(1:len)
+ else
+ write(40,'(a)')' '
+ end if
+ if (line(1)(1:3).eq.'---') type4 = .not.type4
+ else
+ go to 11
+ end if
+10 continue
+ print*,'You should not be here in scor2prt. Call Dr. Don'
+ stop
+11 continue
+c
+c Finished reading opening type4 TeX and comments. Next line to be read
+c will contain the first of the input numbers
+c
+ call dosetup(iv,line(1),mtrnum,mtrden)
+ do 1 i = 1 , 10000
+13 read(10+iv,'(a)',end=999)line(1)
+7 len = lenstr(line(1),128)
+c
+c Pass-through if instrumnet has >1 voice.
+c
+ if (ljob .lt. 0) go to 2
+ if (index('TtTiTch+h-h l ',line(1)(1:2)) .gt. 0) then
+c
+c Traps titles, instruments, composers, headers, lower strings. Read 2 lines.
+c
+ write(40,'(a)')line(1)(1:len)
+ read(10+iv,'(a)')line(1)
+ len = lenstr(line(1),128)
+ go to 2
+ end if
+ if (i.eq.1 .or. (i.gt.5.and.line(1)(1:1).eq.'m')) then
+c
+c NOTE! The above test is truly bogus.
+c
+ if (line(1)(1:1) .eq. '%') then
+ write(40,'(a)')line(1)(1:len)
+ go to 13
+ end if
+ if (i .eq. 1) then
+c read(line(1),'(10x,2i5)')mtrnum,mtrden
+ else
+c
+c Check for slashes (new meter change syntax)
+c
+ idxs = index(line(1),'/')
+ idxb = index(line(1),' ')
+ newmtr = idxs.gt.0 .and. (idxb.eq.0 .or. idxs.lt.idxb)
+ if (.not.newmtr) then
+c
+c Old way, no slashes, uses 'o' for lonesome '1'
+c
+ 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
+ else
+c
+c New way with slashes: idxs is index of 1st slash!
+c
+ read(line(1)(2:idxs-1),'(i'//char(48+idxs-2)//')')mtrnum
+ idxb = index(line(1)(idxs+1:),'/')
+ read(line(1)(idxs+1:idxs+idxb-1),
+ * '(i'//char(48+idxb-1)//')')mtrden
+ end if
+ 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))
+ if (idx .gt. 0) then
+c
+c Check for blank or shifted rest, discount it if it's there
+c
+ if (line1(idx+lwbrs:idx+lwbrs).ne.' ') idx = 0
+ end if
+ else
+ idx = ntindex(line1,'rp')
+c
+c Check for raised rest
+c
+ if (idx.gt.0) then
+ if (line1(idx+2:idx+2).ne.' ') idx = 0
+ end if
+ 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.lt.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(40,'(a)')'% Following comment has been moved forward'
+ write(40,'(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
+ len = lenstr(line(iline),128)
+ 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(40,'(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(40,'(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(40,'(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(40,'(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(40,'(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 continue
+ if (len .gt. 0) then
+ write(40,'(a)')line(1)(1:len)
+ else
+ write(40,'(a)')' '
+ end if
+1 continue
+999 continue
+ close(10+iv)
+ close(40)
+ 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 .or. idur.eq.16) 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 if (lenbar .eq. 128) then
+ wbrsym(1) = 'r9'
+ 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,tline
+ logical intex
+c
+c print*,'Starting ntindex. s2q:',s2q,', line(1:79) is below'
+c print*,line(1:79)
+c
+c
+c Use a temporary string to store the input and test, so can zap D"..."
+c
+ tline = line
+ ndxs2 = index(tline,s2q)
+c
+c Return point below for rechecks after zapping D" "
+c
+2 continue
+ ndxbs = index(tline,char(92))
+ if (ndxbs .gt. 0) then
+c
+c Special check in case \ is inside D"..."
+c
+ ndxDq1 = index(tline,'D"')
+c
+c If the following test fails, flow out of if block; else loop up to 2.
+c
+ if (ndxDq1 .gt. 0) then
+c
+c Find end of D"..."
+c
+ ndxDq2 = ndxDq1+1+index(tline(ndxDq1+2:128),'"')
+ if (ndxDq2 .eq. ndxDq1+1) then
+ print*,'Something is really wierd here'
+ stop
+ end if
+ tline = tline(1:ndxDq1-1)
+ do 3 ic = ndxDq1 , ndxDq2
+ tline = tline(1:ic-1)//' '
+3 continue
+ tline = tline(1:ndxDq2)//line(ndxDq2+1:128)
+ go to 2
+ end if
+ end if
+ 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(tline,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(tline(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. tline(ic+1:ic+2).eq.char(92)//' ') then
+ intex = .false.
+c print*,'intex+>',intex
+ else if (.not.intex .and. tline(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
+ subroutine getchar(line,iccount,charq)
+c
+c Gets the next character out of line*128. If pointer iccount=128 on entry,
+c then reads in a new line. Resets iccount to position of the new character.
+c
+ character*1 charq
+ character*128 line
+ if (iccount .eq. 128) then
+ read(10,'(a)')line
+ iccount = 0
+ end if
+ iccount = iccount+1
+ charq = line(iccount:iccount)
+ return
+ end
+ function readin(line,iccount,iread)
+ parameter (noimax=24)
+ common /all/ noinow,iorig(noimax),noinst,insetup,replacing,
+ * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow
+ logical insetup,replacing,botv
+c
+c Reads a piece of setup data from line, gets a new line from
+c file 10 (jobname.pmx) if needed, Transfers comment lines into all parts.
+c
+c iread controls copying of values into scratch files for parts, but only
+c if not replacing.
+c
+c iread input value written
+c -1 nvi nothing (only used when noinst<0 initially)
+c 0 various value read
+c 1 nv -1 , replace later with nvi(i)
+c 2 noinst 1
+c 3 np -2 , replace later with (nsyst-1)/12+1
+c 4 musicsize 20
+c 5 fracondent 0.05
+c
+ character*128 line
+ character*1 durq
+4 if (iccount .eq. 128) then
+ read(10,'(a)')line
+ if (replacing) replacing = .false.
+ call chkcom(line)
+ iccount = 0
+ end if
+ iccount = iccount+1
+c
+c Find next non-blank or end of line
+c
+ do 2 iccount = iccount , 127
+ if (line(iccount:iccount) .ne. ' ') go to 3
+2 continue
+c
+c If here, need to get a new line
+c
+ iccount = 128
+ go to 4
+3 continue
+c
+c iccount now points to start of number to read
+c
+ i1 = iccount
+5 call getchar(line,iccount,durq)
+c
+c Remember that getchar first increments iccount, *then* reads a character.
+c
+ if (index('0123456789.-',durq) .gt. 0) go to 5
+ i2 = iccount-1
+ if (i2 .lt. i1) then
+ print*,'Found "'//durq//'" instead of number'
+ stop 1
+ end if
+ icf = i2-i1+49
+ read(line(i1:i2),'(f'//char(icf)//'.0)')readin
+ if (.not.replacing) then
+ if (iread .eq. 0) then
+ call allparts(line(i1:i2),i2-i1+1)
+ else if (iread .eq. 1) then
+ call allparts('-999',4)
+ else if (iread .eq. 2) then
+ call allparts('1',1)
+ else if (iread .eq. 3) then
+ call allparts('-998',4)
+ else if (iread .eq. 4) then
+ call allparts('20',2)
+ else if (iread .eq. 5) then
+ call allparts('.05',3)
+ else if (iread .ne. -1) then
+ print*,'Error with iread in readin'
+ stop
+ end if
+ end if
+ return
+ end
+ subroutine chkcom(line)
+ parameter (noimax=24)
+ common /all/ noinow,iorig(noimax),noinst,insetup,replacing,
+ * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow
+ logical insetup,replacing,clefpend,botv
+ character*128 line
+c
+c Assume that line has just been read. No need to change iccount since we only
+c process full lines.
+c
+1 if (line(1:1) .ne. '%') return
+c
+c If here, line has some sort of comment
+c
+ if (line(2:2) .eq. '%') then
+ if (.not. insetup) then
+c
+c Suck up a line, then flow out of "if" block to get another and loop
+c
+ read(10,'(a)')line
+
+c++VV
+c
+c UNLESS (a) it has a score-only "M" and changes # of inst's.
+c
+ if (index(line,'M') .gt. 0) then
+ idxL = index(line,'L')
+ idxM = index(line,'M')
+ idxn = index(line,'n')
+ idxb = index(line,' ')
+ if (idxL.lt.idxM .and. idxM.lt.idxn .and.
+ * (idxb.eq.0 .or. idxn.lt.idxb)) then
+ noinow = ichar(line(idxn+1:idxn+1))-48
+ clefpend = .true.
+c
+c Next noinow digits are original inst. #'s of new inst. set. Next noinow
+c char's after that are clefs
+c
+ nvnow = 0
+ do 24 j = 1 , noinow
+ iorig(j) = ichar(line(idxn+1+j:idxn+1+j))-48
+ iposc0 = idxn+1+noinow
+ do 25 k = 1 , nvi(iorig(j))
+ nvnow = nvnow+1
+c clefq(nvnow) = line(iposc0+nvnow:iposc0+nvnow)
+ instnum(nvnow) = j
+ botv(nvnow) = k.eq.1 .and. j.ne.1
+25 continue
+24 continue
+ end if
+ end if
+c
+c or if it's "h" or "l", need to suck up one more line
+c
+ if ((line(1:1).eq.'h'.and.index('+- ',line(2:2)).gt.0) .or.
+c
+c 4/29/00 check for T string also
+c
+ * line(1:1).eq.'T' .or.
+ * line(1:2).eq.'l ') read(10,'(a)')line
+ else
+c
+c In setup mode. Set flag, flow out and do use following line
+c
+ replacing = .true.
+ end if
+ else if (line(2:2) .eq. '!') then
+c
+c Copy to all parts
+c
+ call allparts(line(3:128),125)
+ else
+c
+c Get value of hex integer 1,2,...,9,a,b,c in 2nd position, zero otherwise
+cc Get value of extended hex integer 1,2,...,9,a,b,c,...,o in 2nd position, zero otherwise
+c
+ ivq = index('123456789abcdefghijklmno',line(2:2))
+c
+c Only treat as part-specific pmx line if number .le. noinst
+c
+ if (ivq.lt.1 .or. ivq.gt.noinst) then
+c
+c Simple comment.
+c
+ call allparts(line,128)
+ else
+c
+c Instrument comment, copy only to part
+c
+ lenline = lenstr(line,128)
+ if (lenline .gt. 2) then
+ write(10+ivq,'(a)')line(3:lenline)
+ else
+c
+c Transferring blank line
+c
+ write(10+ivq,'(a)')' '
+ end if
+ end if
+ end if
+ read(10,'(a)',end=2)line
+ call zapbl(line,128)
+ go to 1
+2 continue
+ return
+ end
+ subroutine dosetup(iv,line,mtrnum,mtrden)
+ parameter (noimax=24)
+c
+c Transfers setup data from scratch file to real one for one instrument
+c Data may be mixed with comments, but on entry 1st item is a number.
+c Write a comment when encountered, as it comes.
+c Write numbers one per line.
+c Three input data require special handling:
+c If not already replaced, i.e., if negative, then
+c iset(1) (nv) will be replaced with nvi(i)
+c iset(9) (npages) will be replaced with (nsyst-1)/12+1
+c iset(2), if negative, will be followed by extra numbers to be transf.
+c
+ common /all/ noinow,iorig(noimax),noinst,insetup,replacing,
+ * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow
+ logical insetup,replacing,clefpend,botv
+ character*128 line
+ iccount = 0
+ do 1 iset = 1 , 12
+ call partnum(iv,iccount,line,xdata)
+ if (iset .eq. 2) then
+ if (xdata .gt. 0) then
+ write(40,'(i5)')int(xdata+.1)
+ else
+ noi = -xdata+.1
+ write(40,'(i5)')noi
+ do 2 ioi = 1 , noi
+ call partnum(iv,iccount,line,xdata)
+ write(40,'(i5)')int(xdata+.1)
+2 continue
+ end if
+c else if (iset.ne.8 .and. xdata.lt.0) then
+ else if (iset.ne.8 .and. iset.ne.5 .and. xdata.lt.0) then
+c
+c Must be either nv or npages
+c
+ if (int(-xdata+.1) .eq. 999) then
+c
+c It's nv
+c
+ write(40,'(i5)')nvi(iv)
+ else
+c
+c npages must be computed
+c
+ write(40,'(i5)')(nsyst-1)/12+1
+ end if
+ else if (iset.ne.7 .and. iset.ne.12) then
+c
+c write integer
+c
+ write(40,'(i5)')nint(xdata)
+ else
+c
+c write floating number
+c
+ write(40,'(f5.2)')xdata
+ end if
+ if (iset .eq. 3) then
+ mtrnum = nint(xdata)
+ else if (iset .eq. 4) then
+ mtrden = nint(xdata)
+ end if
+1 continue
+ return
+ end
+ subroutine partnum(iv,iccount,line,xdata)
+c
+c Simplified number parsing. Only looks for comment lines and numbers.
+c
+ character*128 line
+ character*1 durq
+2 if (iccount .eq. 128) then
+ read(10+iv,'(a)')line
+ if (line(1:1) .eq. '%') then
+ len = lenstr(line,128)
+ write(40,'(a)')line(1:len)
+ go to 2
+ end if
+ iccount = 0
+ end if
+ iccount = iccount+1
+c
+c Find next non-blank or end of line
+c
+ do 4 iccount = iccount , 127
+ if (line(iccount:iccount) .ne. ' ') go to 3
+4 continue
+c
+c If here, iccount=128 and need to get a new line
+c
+ go to 2
+3 continue
+c
+c iccount now points to start of number to read
+c
+ i1 = iccount
+5 call getchar(line,iccount,durq)
+c
+c Remember that getchar first increments iccount, *then* reads a character.
+c
+ if (index('0123456789.-',durq) .gt. 0) go to 5
+ i2 = iccount-1
+ if (i2 .lt. i1) then
+ print*,'Found "'//durq//'" instead of number'
+ stop 1
+ end if
+ icf = i2-i1+49
+ read(line(i1:i2),'(f'//char(icf)//'.0)')xdata
+ return
+ end
+ block data
+ parameter (noimax=24)
+ common /all/ noinow,iorig(noimax),noinst,insetup,replacing,
+ * instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow
+ logical insetup,replacing,botv
+ data nvi /noimax*1/, noinst,noinow /2*noimax/
+ data botv /noimax*.false./
+ end
+ subroutine zapbl(string,len)
+ character*(*) string
+ do 1 i = 1 , len
+ if (string(i:i) .eq. ' ')go to 1
+ if (i .eq. 1) return
+ go to 2
+1 continue
+c
+c If line is all blank, leave it alone
+c
+ return
+2 continue
+ string = string(i:len)
+ return
+ end
+ subroutine OddQuotesBefore(lineq,indx,yesodd)
+c
+c This counts number of double quotes in lineq up to position indx-1, then
+c sets yesodd according to whether number is odd or even
+c
+ logical yesodd
+ character*(*) lineq
+ numdqs = 0
+ do 1 i = 1 , indx-1
+ if (lineq(i:i) .eq. '"') numdqs = numdqs+1
+1 continue
+ yesodd = mod(numdqs,2) .eq. 1
+ return
+ end
+
+
+
+
+