cccccccccccccccccccccccccc
cc
cc scor2prt 2/19/16 for PMX 2.74
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 .
c
c 2/19/16
c Exit gracefully when last input line is comment, with mods in
c subroutine chkcom, adding logical argument goto999
c which is set to .true. in that case, causing input file to
c be closed after exiting.
c 4/9/12
c Add logical declarations to subroutine dosetup
c 8/8/11
c Copy & mod Ki into parts when after beginning.
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,goto999
character*1 dumq
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.74, 19 February 2016'
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,goto999)
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,goto999)
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,goto999)
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,goto999)
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,goto999)
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 continue
read(10,'(a)',end=999)line
lenline = lenstr(line,128)
if (lenline .eq. 0) go to 4
call zapbl(line,128)
call chkcom(line,goto999)
if (goto999) go to 999
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,goto999)
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)
if (iv .lt. 10) then
partq(1:1) = char(48+iv)
lpart = 1
else
lpart = 2
if (iv .lt. 20) then
partq = '1'//char(38+iv)
else
partq = '2'//char(28+iv)
end if
end if
c 130327
c open(40,file=jobname(1:abs(ljob))//partq(1:lpart)//'.pmx')
if (ludpfn .eq. 0) then
open(40,file=jobname(1:abs(ljob))//partq(1:lpart)//'.pmx')
else
open(40,file=udpfnq(1:ludpfn)//'.pmx')
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 (and copy into part file) 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 Either just starting, or a new meter is defined.
c NOTE! The above test may be bogus.
c
if (line(1)(1:1) .eq. '%') then
write(40,'(a)')line(1)(1:len)
go to 13
end if
if (i .ne. 1) then
c
c New meter. 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
c
c Finished setting up meter stuff and defining whole-bar rest symbols
c
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) ! Maybe allows e.g. r0 rp ...
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 ! ip at end of 1st wbrsym
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 '
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,goto999
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,goto999)
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,goto999)
parameter (noimax=24)
common /all/ noinow,iorig(noimax),noinst,insetup,replacing,
* instnum(noimax),botv(noimax),nvi(noimax),nsyst,nvnow
logical insetup,replacing,clefpend,botv,goto999
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
goto999 = .false.
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
goto999 = .true.
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
character*128 line
logical insetup,replacing,botv
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