/* scor2prt.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ #include "f2c.h" /* Common Block Declarations */ struct all_1_ { integer noinow, iorig[12], noinst; logical insetup, replacing; integer instnum[12]; logical botv[12]; integer nvi[12], nsyst, nvnow; }; struct all_2_ { integer noinow, iorig[12], noinst, insetup; real replacing; integer instnum[12]; real botv[12]; integer nvi[12], nsyst, nvnow; }; #define all_1 (*(struct all_1_ *) &all_) #define all_2 (*(struct all_2_ *) &all_) /* Initialized data */ struct { integer e_1; integer fill_2[12]; integer e_3; integer fill_4[14]; logical e_5[12]; integer e_6[12]; integer fill_7[2]; } all_ = { 12, {0}, 12, {0}, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, FALSE_, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 }; /* Table of constant values */ static integer c__9 = 9; static integer c__1 = 1; static integer c__27 = 27; static integer c__2 = 2; static integer c__128 = 128; static integer c_n1 = -1; static integer c__0 = 0; static integer c__3 = 3; static integer c__4 = 4; static integer c__5 = 5; static integer c__79 = 79; static integer c__125 = 125; /* ccccccccccccccccccccccccc */ /* c */ /* c scor2prt for PMX Version 2.2 (s2p14.for) 3/20/00 */ /* c */ /* ccccccccccccccccccccccccc */ /* To do */ /* Override fracindent, musicsize? */ /* Deal with midbar R? */ /* s2p14 */ /* Fix bypass of MIDI commands. */ /* Restore change from "Version 2.1a, 21 Dec" */ /* s2p13 */ /* Allow whole-bar double-whole rests. */ /* Bypass MIDI commands "I..." achar(10)="I" */ /* s2p12 */ /* Let %ablabla ... %cblabla represent pmx input for parts 10-12. But %?blabla */ /* only taken as such if ? represents a hex digit .le. noinst, otherwise it's */ /* a simple comment. This lessens incompatibility. */ /* In subroutine mbrest, properly open parts 10-12 if needed */ /* s2p11 */ /* Ignore leading blanks */ /* Fix undefined linelength in mbrest at very end of comments. */ /* s2p10 */ /* Fix non-transfer of P..c" " */ /* Allow "%%" and "%"n anywhere */ /* Version 1.43 */ /* Fix bug with P in TeX string. */ /* Ignore shifted whole-bar rests when consolidating whole-bar rests */ /* Copy type 4 TeX into all parts. */ /* Deal with XB and XP. */ /* Permit transfer of blank line into parts */ /* Change staves/inst in 'M' command. */ /* Arbitrary staves/inst. */ /* Recognize m1/2/3/4 syntax. */ /* Enable comment and one-voice syntax in instrument names */ /* Changes since 1.1 */ /* Deal with saved macros. */ /* Revise setup readin, to admit comments. */ /* Do not copy 'X' into parts */ /* ccccccccccccccccccccccccccccccccccccccccccccccc */ /* Main program */ MAIN__() { /* Initialized data */ static char achar[1*10+1] = "PmVRAhwKMI"; /* System generated locals */ address a__1[2], a__2[3]; integer i__1, i__2, i__3[2], i__4[3]; char ch__1[44], ch__2[31], ch__3[4], ch__4[1], ch__5[2]; cilist ci__1; olist o__1; cllist cl__1; alist al__1; inlist ioin__1; /* Builtin functions */ integer s_wsle(), do_lio(), e_wsle(), s_rsfe(), do_fio(), e_rsfe(); /* Subroutine */ int s_stop(); integer i_indx(); /* Subroutine */ int s_copy(), s_cat(); integer f_inqu(), f_open(), s_cmp(), f_back(), s_wsfe(), e_wsfe(), f_clos( ); /* Local variables */ static integer nchk, idxa, ljob; static char line[128]; static integer isig, locp, idum; static logical clefpend; static integer idxq, ndxm; static real xmtrnum0; static integer inst; static char templine[128]; extern /* Subroutine */ int allparts_(); static integer idxq2; extern integer iargc_(); static integer kvend; extern /* Subroutine */ int zapbl_(); static integer iinst, ntinx; static logical oneof2; static integer musicsize, ia, ib, ic, iv; extern doublereal readin_(); static char sq[1]; extern /* Subroutine */ int chkcom_(); static integer nv; extern /* Subroutine */ int getarg_(); static integer npages; static char holdln[128]; static real fracindent; static logical fexist; static integer ivlast, mtrdnp; extern integer lenstr_(); static logical frstln; static integer insnow, ndxpmx, mtrnmp, len; static logical isachar; static char jobname[27]; static integer ivq, lenhold, lenline; static char infileq[27]; static logical gotname; static integer iccount, mtrdenl; extern integer ntindex_(); static integer numargs; extern /* Subroutine */ int mbrests_(); static logical termrpt; static integer mtrnuml; static char termsym[2], instrum[128*12]; static integer kvstart; /* Fortran I/O blocks */ static cilist io___6 = { 0, 6, 0, 0, 0 }; static cilist io___8 = { 0, 6, 0, 0, 0 }; static cilist io___9 = { 0, 6, 0, 0, 0 }; static cilist io___10 = { 0, 5, 0, "(a)", 0 }; static cilist io___14 = { 0, 6, 0, 0, 0 }; static cilist io___18 = { 0, 6, 0, 0, 0 }; static cilist io___20 = { 0, 10, 0, "(a)", 0 }; static cilist io___22 = { 0, 10, 0, "(a)", 0 }; static cilist io___23 = { 0, 10, 0, "(a)", 0 }; static cilist io___38 = { 0, 6, 0, 0, 0 }; static cilist io___39 = { 0, 6, 0, 0, 0 }; static cilist io___40 = { 0, 6, 0, 0, 0 }; static cilist io___41 = { 0, 10, 0, "(a)", 0 }; static cilist io___42 = { 0, 10, 0, "(a)", 0 }; static cilist io___44 = { 0, 10, 0, "(a)", 0 }; static cilist io___46 = { 0, 10, 0, "(a)", 0 }; static cilist io___48 = { 0, 6, 0, 0, 0 }; static cilist io___49 = { 0, 0, 0, "(a)", 0 }; static cilist io___50 = { 0, 10, 0, "(a)", 0 }; static cilist io___51 = { 0, 10, 0, "(a)", 0 }; static cilist io___55 = { 0, 10, 0, "(a)", 0 }; static cilist io___57 = { 0, 0, 0, "(a2/a)", 0 }; static cilist io___59 = { 0, 10, 1, "(a)", 0 }; static cilist io___61 = { 0, 10, 0, "(a)", 0 }; static cilist io___62 = { 0, 10, 0, "(a)", 0 }; static cilist io___67 = { 0, 6, 0, 0, 0 }; static cilist io___68 = { 0, 6, 0, 0, 0 }; static cilist io___73 = { 0, 6, 0, 0, 0 }; static cilist io___74 = { 0, 6, 0, 0, 0 }; static cilist io___75 = { 0, 6, 0, 0, 0 }; static cilist io___78 = { 0, 10, 0, "(a)", 0 }; static cilist io___84 = { 0, 0, 0, "(a)", 0 }; static cilist io___85 = { 0, 0, 0, "(a)", 0 }; clefpend = FALSE_; all_1.insetup = TRUE_; all_1.replacing = FALSE_; frstln = TRUE_; lenhold = 0; *(unsigned char *)sq = '\\'; s_wsle(&io___6); do_lio(&c__9, &c__1, "This is scor2prt s2p14, 20 March 00", (ftnlen)35); e_wsle(); numargs = iargc_(); if (numargs == 0) { s_wsle(&io___8); do_lio(&c__9, &c__1, "You could have entered a jobname on the comman\ d line,", (ftnlen)53); e_wsle(); s_wsle(&io___9); do_lio(&c__9, &c__1, " but you may enter one now:", (ftnlen)32); e_wsle(); s_rsfe(&io___10); do_fio(&c__1, jobname, (ftnlen)27); e_rsfe(); numargs = 1; } else { getarg_(&c__1, jobname, &idum, (ftnlen)27); /* call getarg(1,jobname) */ /* May need to replace this w/ next l */ } ljob = lenstr_(jobname, &c__27, (ftnlen)27); if (ljob == 0) { s_wsle(&io___14); do_lio(&c__9, &c__1, "No was jobname entered. Restart and try again.", (ftnlen)46); e_wsle(); s_stop("", (ftnlen)0); } /* Strip ".pmx" if necessary */ /* Computing MAX */ i__1 = i_indx(jobname, ".pmx", (ftnlen)27, (ftnlen)4), i__2 = i_indx( jobname, ".PMX", (ftnlen)27, (ftnlen)4); ndxpmx = max(i__1,i__2); if (ndxpmx > 0) { s_copy(jobname, jobname, (ftnlen)27, ndxpmx - 1); ljob += -4; } /* Check for existence of input file */ /* Writing concatenation */ i__3[0] = ljob, a__1[0] = jobname; i__3[1] = 4, a__1[1] = ".pmx"; s_cat(infileq, a__1, i__3, &c__2, (ftnlen)27); ioin__1.inerr = 0; ioin__1.infilen = 27; ioin__1.infile = infileq; ioin__1.inex = &fexist; ioin__1.inopen = 0; ioin__1.innum = 0; ioin__1.innamed = 0; ioin__1.inname = 0; ioin__1.inacc = 0; ioin__1.inseq = 0; ioin__1.indir = 0; ioin__1.infmt = 0; ioin__1.inform = 0; ioin__1.inunf = 0; ioin__1.inrecl = 0; ioin__1.innrec = 0; ioin__1.inblank = 0; f_inqu(&ioin__1); if (! fexist) { s_wsle(&io___18); /* Writing concatenation */ i__3[0] = 17, a__1[0] = "Cannot find file "; i__3[1] = 27, a__1[1] = infileq; s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)44); do_lio(&c__9, &c__1, ch__1, (ftnlen)44); e_wsle(); s_stop("", (ftnlen)0); } o__1.oerr = 0; o__1.ounit = 10; o__1.ofnmlen = ljob + 4; /* Writing concatenation */ i__3[0] = ljob, a__1[0] = jobname; i__3[1] = 4, a__1[1] = ".pmx"; s_cat(ch__2, a__1, i__3, &c__2, (ftnlen)31); o__1.ofnm = ch__2; o__1.orl = 0; o__1.osta = 0; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; f_open(&o__1); /* Open all instrument files now for allparts stuff. Later disgard those >nv */ for (iv = 1; iv <= 12; ++iv) { all_1.iorig[iv - 1] = iv; o__1.oerr = 0; o__1.ounit = iv + 10; o__1.ofnm = 0; o__1.orl = 0; o__1.osta = "SCRATCH"; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; f_open(&o__1); /* L19: */ } s_rsfe(&io___20); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); chkcom_(line, (ftnlen)128); if (s_cmp(line, "---", (ftnlen)3, (ftnlen)3) == 0) { allparts_(line, &c__128, (ftnlen)128); L31: s_rsfe(&io___22); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); if (s_cmp(line, "---", (ftnlen)3, (ftnlen)3) != 0) { allparts_(line, &c__128, (ftnlen)128); goto L31; } allparts_(line, &c__128, (ftnlen)128); s_rsfe(&io___23); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); chkcom_(line, (ftnlen)128); } iccount = 0; nv = readin_(line, &iccount, &c__1, (ftnlen)128) + (float).1; all_1.noinst = readin_(line, &iccount, &c__2, (ftnlen)128) + (float).1; if (all_1.noinst > 0) { all_1.nvi[0] = nv - all_1.noinst + 1; } else { all_1.noinst = 1 - all_1.noinst; i__1 = all_1.noinst; for (iinst = 1; iinst <= i__1; ++iinst) { all_1.nvi[iinst - 1] = readin_(line, &iccount, &c_n1, (ftnlen)128) + (float).1; /* L21: */ } } all_1.noinow = all_1.noinst; insnow = 1; /* ivlast is last iv in current inst. instnum(iv) is iinst for current voice. */ ivlast = all_1.nvi[0]; i__1 = nv; for (iv = 1; iv <= i__1; ++iv) { all_1.instnum[iv - 1] = insnow; if (iv == ivlast) { if (iv < nv) { all_1.botv[iv] = TRUE_; } /* The previous stmt will set botv true only for bot voice of iinst>1. It is */ /* used when writing termrpts, but the one in voice one is handled differently, */ /* so botv(1) is left .false. */ if (insnow < all_1.noinst) { ++insnow; ivlast += all_1.nvi[insnow - 1]; } } /* L22: */ } mtrnuml = readin_(line, &iccount, &c__0, (ftnlen)128) + (float).1; mtrdenl = readin_(line, &iccount, &c__0, (ftnlen)128) + (float).1; mtrnmp = readin_(line, &iccount, &c__0, (ftnlen)128) + (float).1; mtrdnp = readin_(line, &iccount, &c__0, (ftnlen)128) + (float).1; xmtrnum0 = readin_(line, &iccount, &c__0, (ftnlen)128); isig = readin_(line, &iccount, &c__0, (ftnlen)128) + (float).1; npages = readin_(line, &iccount, &c__3, (ftnlen)128) + (float).1; all_1.nsyst = readin_(line, &iccount, &c__0, (ftnlen)128) + (float).1; musicsize = readin_(line, &iccount, &c__4, (ftnlen)128) + (float).1; fracindent = readin_(line, &iccount, &c__5, (ftnlen)128); if (npages == 0) { s_wsle(&io___38); do_lio(&c__9, &c__1, "You entered npages=0, which means nsyst is not\ the total number", (ftnlen)63); e_wsle(); s_wsle(&io___39); do_lio(&c__9, &c__1, "of systems. Scor2prt has to know the total nu\ mber of systems.", (ftnlen)62); e_wsle(); s_wsle(&io___40); do_lio(&c__9, &c__1, "Please set npages and nsyst to their real valu\ es.", (ftnlen)49); e_wsle(); s_stop("", (ftnlen)0); } /* Must leave insetup=.true. else could bypass ALL instrument names. */ s_rsfe(&io___41); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); chkcom_(line, (ftnlen)128); al__1.aerr = 0; al__1.aunit = 10; f_back(&al__1); /* Normally this puts pointer at start of line with 1st inst name */ /* Check if prior line was "%%" */ al__1.aerr = 0; al__1.aunit = 10; f_back(&al__1); s_rsfe(&io___42); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); if (s_cmp(line, "%%", (ftnlen)2, (ftnlen)2) == 0) { al__1.aerr = 0; al__1.aunit = 10; f_back(&al__1); } i__1 = all_1.noinst; for (iv = 1; iv <= i__1; ++iv) { gotname = FALSE_; L16: s_rsfe(&io___44); do_fio(&c__1, instrum + (iv - 1 << 7), (ftnlen)128); e_rsfe(); if (s_cmp(instrum + (iv - 1 << 7), "%%", (ftnlen)2, (ftnlen)2) == 0) { s_rsfe(&io___46); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); goto L16; } else if (*(unsigned char *)&instrum[(iv - 1) * 128] == '%') { ivq = *(unsigned char *)&instrum[(iv - 1 << 7) + 1] - 48; if (ivq != iv) { /* It's really a comment. Copy to parts, then get another trial name. */ allparts_(instrum + (iv - 1 << 7), &c__128, (ftnlen)128); goto L16; } else { s_copy(line, instrum + ((iv - 1 << 7) + 2), (ftnlen)128, ( ftnlen)126); s_copy(instrum + (iv - 1 << 7), line, (ftnlen)128, (ftnlen) 128); gotname = TRUE_; } } else { gotname = TRUE_; } /* c */ /* c The following checks for macro that write original C-clef as part of */ /* c instrument name. See pmx.tex */ /* c */ /* if (index(instrum(iv),'namewpc') .eq. 0) then */ /* write(10+iv,'(a)')' ' */ /* else */ /* inm1 = index(instrum(iv),'{')+1 */ /* inm2 = index(instrum(iv),'}')-1 */ /* read(instrum(iv)(inm2+2:inm2+8),'(i1,4x,2i1)')ilev,iy1,iy2 */ /* write(10+iv,'(a)')sq//'namewpc{}'//char(ilev+48)//'{20}'// */ /* * char(iy1+49)//char(iy2+49) */ /* instrum(iv) = instrum(iv)(inm1:inm2) */ /* end if */ if (! gotname) { s_wsle(&io___48); do_lio(&c__9, &c__1, "You must provide a replacement instrument \ name", (ftnlen)46); e_wsle(); s_stop("", (ftnlen)0); } io___49.ciunit = iv + 10; s_wsfe(&io___49); do_fio(&c__1, " ", (ftnlen)1); e_wsfe(); /* L14: */ } all_1.replacing = FALSE_; all_1.nvnow = nv; /* Clef string: Note insetup is still T, so "%%" will be treated specially */ s_rsfe(&io___50); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); chkcom_(line, (ftnlen)128); if (all_1.replacing) { /* If here, we have next line after "%%", containing score's clef string */ /* Assume all clefs are handled with instrument comments. */ s_rsfe(&io___51); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); chkcom_(line, (ftnlen)128); al__1.aerr = 0; al__1.aunit = 10; f_back(&al__1); } else { /* If here, line has the clef string in it. Handle the old way */ kvstart = 1; kvend = all_1.nvi[0]; i__1 = all_1.noinst; for (inst = 1; inst <= i__1; ++inst) { ci__1.cierr = 0; ci__1.ciunit = inst + 10; /* Writing concatenation */ i__4[0] = 2, a__2[0] = "(a"; *(unsigned char *)&ch__4[0] = all_1.nvi[inst - 1] + 48; i__4[1] = 1, a__2[1] = ch__4; i__4[2] = 1, a__2[2] = ")"; ci__1.cifmt = (s_cat(ch__3, a__2, i__4, &c__3, (ftnlen)4), ch__3); s_wsfe(&ci__1); do_fio(&c__1, line + (kvstart - 1), kvend - (kvstart - 1)); e_wsfe(); if (inst < all_1.noinst) { kvstart = kvend + 1; kvend = kvstart + all_1.nvi[inst] - 1; } /* L2: */ } } all_1.replacing = FALSE_; all_1.insetup = FALSE_; /* *****NOTE*****This comment applies to stuff done earlier! */ /* Before starting the big loop, copy initial instnum and staffnum stuff */ /* into working values. Latter may change if noinst changes. Also make */ /* list of current inst nums relative to original ones. In addition to those */ /* below, must redo instnum(iv) and botv(iv) when we change noinst. */ /* Path string: ASSUME THIS WILL NEVER BE ALTERED IN PARTS! */ L18: s_rsfe(&io___55); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); if (*(unsigned char *)line == '%') { allparts_(line, &c__128, (ftnlen)128); goto L18; } allparts_(line, &c__128, (ftnlen)128); /* Write instrument names. Will be blank if later part of a score. */ if (*(unsigned char *)&instrum[0] != ' ') { i__1 = all_1.noinst; for (iv = 1; iv <= i__1; ++iv) { len = lenstr_(instrum + (iv - 1 << 7), &c__79, (ftnlen)128); io___57.ciunit = iv + 10; s_wsfe(&io___57); do_fio(&c__1, "Ti", (ftnlen)2); do_fio(&c__1, instrum + (iv - 1 << 7), len); e_wsfe(); /* L3: */ } } /* The big loop. Except for '%%', put all comment lines in all parts. */ /* Unless preceeded by '%%', put all type 2 or 3 TeX Strings in all parts */ /* If a line starts with %!, put the rest of it in each part. */ /* If a line starts with %[n], put the rest of it in part [n]. */ /* Check for Tt, Tc, Voltas, Repeats, headers, lower texts, meter changes. */ /* Assume they only come at top of block, except terminal repeat needs */ /* special handling. */ /* Check for "P"; ignore in parts. */ /* Check for consecutive full-bar rests; if found, replace with rm[nn] */ iv = 1; iinst = 1; termrpt = FALSE_; L4: i__1 = s_rsfe(&io___59); if (i__1 != 0) { goto L999; } i__1 = do_fio(&c__1, line, (ftnlen)128); if (i__1 != 0) { goto L999; } i__1 = e_rsfe(); if (i__1 != 0) { goto L999; } lenline = lenstr_(line, &c__128, (ftnlen)128); if (lenline == 0) { goto L4; } zapbl_(line, &c__128, (ftnlen)128); chkcom_(line, (ftnlen)128); lenline = lenstr_(line, &c__128, (ftnlen)128); if (lenline == 0) { goto L4; } if (*(unsigned char *)line == 'T') { allparts_(line, &c__128, (ftnlen)128); s_rsfe(&io___61); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); allparts_(line, &c__128, (ftnlen)128); goto L4; } else /* if(complicated condition) */ { /* Writing concatenation */ i__3[0] = 1, a__1[0] = sq; i__3[1] = 1, a__1[1] = sq; s_cat(ch__5, a__1, i__3, &c__2, (ftnlen)2); if (s_cmp(line, ch__5, (ftnlen)2, (ftnlen)2) == 0) { allparts_(line, &c__128, (ftnlen)128); goto L4; } else if (i_indx("hl", line, (ftnlen)2, (ftnlen)1) > 0 && i_indx( " +-", line + 1, (ftnlen)3, (ftnlen)1) > 0) { allparts_(line, &c__128, (ftnlen)128); s_rsfe(&io___62); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); allparts_(line, &c__128, (ftnlen)128); goto L4; } else if (iv == 1) { for (ia = 1; ia <= 10; ++ia) { L24: idxa = ntindex_(line, achar + (ia - 1), (ftnlen)128, (ftnlen) 1); isachar = idxa > 0; if (idxa > 1) { i__1 = idxa - 2; isachar = s_cmp(line + i__1, " ", idxa - 1 - i__1, ( ftnlen)1) == 0; } if (ia == 9) { i__1 = idxa; isachar = isachar && s_cmp(line + i__1, "S", idxa + 1 - i__1, (ftnlen)1) == 0; } if (isachar) { /* Find next blank */ for (ib = idxa + 1; ib <= 128; ++ib) { if (*(unsigned char *)&line[ib - 1] == ' ') { goto L7; } /* L6: */ } s_wsle(&io___67); do_lio(&c__9, &c__1, "Problem with \"V,R,m,P,A,h,MS, o\ r w\"", (ftnlen)35); e_wsle(); s_wsle(&io___68); do_lio(&c__9, &c__1, "Send files to Dr. Don at dsimons@l\ ogicon.com", (ftnlen)44); e_wsle(); s_stop("1", (ftnlen)1); L7: /* Next blank is at position ib. Later, if ia=1, must check for Pc" " ; */ /* i.e., look for '"' between P and blank */ if (ia == 4) { /* Check for terminal repeat. Note if there's a term rpt, there can't be any */ /* others. Also, must process repeats LAST, after m's and 'V's */ for (ic = ib + 1; ic <= 128; ++ic) { if (i_indx(" /", line + (ic - 1), (ftnlen)2, ( ftnlen)1) == 0) { goto L9; } if (*(unsigned char *)&line[ic - 1] == '/') { termrpt = TRUE_; i__1 = ib - 3; s_copy(termsym, line + i__1, (ftnlen)2, ib - 1 - i__1); /* Process the line as if there were no "R" */ goto L10; } /* L8: */ } /* If here, all chars after "R" symbol are blanks, so process the line normally */ } else if (ia == 1) { idxq = ntindex_(line, "\"", (ftnlen)128, (ftnlen)1); if (idxq > idxa && idxq < ib) { /* Quote is between P and next blank. Find 2nd quote, starting at the blank. */ idxq2 = ib - 1 + ntindex_(line, "\"", (ftnlen)128, (ftnlen)1); i__1 = idxq2; if (idxq == 0 || s_cmp(line + i__1, " ", idxq2 + 1 - i__1, (ftnlen)1) != 0) { s_wsle(&io___73); e_wsle(); s_wsle(&io___74); do_lio(&c__9, &c__1, "Error copying P with q\ uotes, idxq2:", (ftnlen)35); do_lio(&c__3, &c__1, (char *)&idxq2, (ftnlen) sizeof(integer)); e_wsle(); s_wsle(&io___75); do_lio(&c__9, &c__1, line, (ftnlen)60); e_wsle(); s_stop("1", (ftnlen)1); } ib = idxq2 + 1; } /* Do not transfer P into parts. */ goto L12; } else if (ia == 9) { /* Start Saving a macro. After leaving here, a symbol will be sent to all parts, */ /* If all on this line, set ib to end and exit normally. */ i__1 = ib; ndxm = i_indx(line + i__1, "M", 128 - i__1, (ftnlen)1) ; i__1 = ib + ndxm - 2; if (ndxm > 0 && s_cmp(line + i__1, " ", ib + ndxm - 1 - i__1, (ftnlen)1) == 0) { /* Macro ends on this line */ ib = ib + ndxm + 1; } else { /* Save leading part of current line */ lenhold = idxa - 1; if (lenhold > 0) { s_copy(holdln, line, (ftnlen)128, lenhold); } /* Transfer rest of line */ i__1 = 129 - idxa; allparts_(line + (idxa - 1), &i__1, 128 - (idxa - 1)); /* Read next line */ L20: s_rsfe(&io___78); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); /* Check for comment, transfer and loop if so */ /* if (line(1:1) .eq.'%') then */ L23: if (*(unsigned char *)line == '%') { /* call allparts(line,128) */ /* go to 20 */ chkcom_(line, (ftnlen)128); goto L23; } /* Look for terminal ' M' */ if (*(unsigned char *)line == 'M') { ndxm = 1; } else { ndxm = i_indx(line, " M", (ftnlen)128, ( ftnlen)2); if (ndxm > 0) { ++ndxm; } } if (ndxm > 0) { /* Set parameters, exit normally (but later check for leading part of 1st line */ idxa = 1; ib = ndxm + 1; } else { /* No "M", transfer entire line, loop */ allparts_(line, &c__128, (ftnlen)128); goto L20; } } } else if (ia == 10) { /* Do not transfer MIDI command into parts */ goto L12; } L9: i__1 = ib - idxa; allparts_(line + (idxa - 1), &i__1, ib - 1 - (idxa - 1)); L12: /* Remove the string from line */ if (idxa == 1) { s_copy(line, line + (ib - 1), (ftnlen)128, 128 - (ib - 1)); } else { /* Writing concatenation */ i__3[0] = idxa - 1, a__1[0] = line; i__3[1] = 128 - (ib - 1), a__1[1] = line + (ib - 1); s_cat(line, a__1, i__3, &c__2, (ftnlen)128); } lenline = lenstr_(line, &c__128, (ftnlen)128); /* Loop if only blanks are left */ if (lenline == 0) { goto L4; } /* Must check for multiple "I" commands, so go to just after start of ia loop */ if (ia == 10) { goto L24; } /* Tack on front part from 1st line of saved macro */ if (lenhold > 0) { /* Writing concatenation */ i__4[0] = lenhold, a__2[0] = holdln; i__4[1] = 1, a__2[1] = " "; i__4[2] = lenline, a__2[2] = line; s_cat(line, a__2, i__4, &c__3, (ftnlen)128); lenhold = 0; } } /* L5: */ } } } /* Now a special loop to deal with 'X'. If it was %[n]X..., will have been */ /* copied into part [n] already. If no "B" or "P", remove. If "P", just */ /* remove the "P" so pmxa/b will process. If "B". do nothing. */ L10: nchk = 1; L13: ntinx = nchk - 1 + ntindex_(line + (nchk - 1), "X", 128 - (nchk - 1), ( ftnlen)1); if (ntinx > nchk - 1) { /* There is a non-TeX 'X' at ntinx. Loop if neither 1st nor after a blank. */ if (ntinx > 1) { i__1 = ntinx - 2; if (s_cmp(line + i__1, " ", ntinx - 1 - i__1, (ftnlen)1) != 0) { /* The X is not 1st char of PMX command. Advance starting point, loop. */ nchk = ntinx + 1; goto L13; } } /* We now know the X at ntinx starts a PMX command. Find next blank */ i__1 = ntinx; ib = ntinx + i_indx(line + i__1, " ", 128 - i__1, (ftnlen)1); /* There must be a blank to right of "X", so ib>ntinx */ /* locp = nchk-1+index(line(nchk:ib),'P') */ i__1 = ntinx; locp = ntinx + i_indx(line + i__1, "P", ib - i__1, (ftnlen)1); /* Did not need to use ntindex because we already know bounds of PMX command. */ /* if (locp .gt. nchk-1) then */ if (locp > ntinx) { /* Strip out the 'P' */ s_copy(templine, line, (ftnlen)128, locp - 1); i__1 = locp; /* Writing concatenation */ i__3[0] = locp - 1, a__1[0] = templine; i__3[1] = lenline - i__1, a__1[1] = line + i__1; s_cat(line, a__1, i__3, &c__2, (ftnlen)128); --lenline; --ib; } if (i_indx(line + (ntinx - 1), ":", ib - (ntinx - 1), (ftnlen)1) > 0 || i_indx(line + (ntinx - 1), "S", ib - (ntinx - 1), (ftnlen) 1) > 0 || i_indx(line + (ntinx - 1), "B", ib - (ntinx - 1), ( ftnlen)1) > 0 || locp > ntinx) { /* The X command is a shift, "Both", or "Part". Do not remove. */ nchk = ib + 1; goto L13; } /* Remove the X command. */ if (ntinx == 1) { if (ib < lenline) { i__1 = ib; s_copy(line, line + i__1, (ftnlen)128, lenline - i__1); } else { /* line contains ONLY the "X" command, so get a new line */ goto L4; } } else { s_copy(templine, line, (ftnlen)128, ntinx - 1); if (ib < lenline) { i__1 = ib; /* Writing concatenation */ i__3[0] = ntinx - 1, a__1[0] = templine; i__3[1] = lenline - i__1, a__1[1] = line + i__1; s_cat(line, a__1, i__3, &c__2, (ftnlen)128); } else { s_copy(line, templine, (ftnlen)128, ntinx - 1); } } /* Recompute lenline */ lenline = lenstr_(line, &c__128, (ftnlen)128); /* Resume checking after location of removed command. */ nchk = ntinx; goto L13; } /* End of loop for X-checks */ oneof2 = ntindex_(line, "//", (ftnlen)128, (ftnlen)2) > 0; if (termrpt && all_1.botv[iv - 1] && frstln && *(unsigned char *)&line[ lenline - 1] == '/') { /* Must add a terminal repeat before the slash */ if (oneof2) { --lenline; } if (lenline > 1) { io___84.ciunit = all_1.iorig[iinst - 1] + 10; s_wsfe(&io___84); do_fio(&c__1, line, lenline - 1); e_wsfe(); } if (! oneof2) { /* Writing concatenation */ i__3[0] = 2, a__1[0] = termsym; i__3[1] = 2, a__1[1] = " /"; s_cat(line, a__1, i__3, &c__2, (ftnlen)128); lenline = 4; } else { /* Writing concatenation */ i__3[0] = 2, a__1[0] = termsym; i__3[1] = 3, a__1[1] = " //"; s_cat(line, a__1, i__3, &c__2, (ftnlen)128); lenline = 5; } } if (termrpt && frstln && *(unsigned char *)&line[lenline - 1] == '/' && iv == all_1.nvnow) { termrpt = FALSE_; } io___85.ciunit = all_1.iorig[iinst - 1] + 10; s_wsfe(&io___85); do_fio(&c__1, line, lenline); e_wsfe(); if (oneof2) { frstln = FALSE_; } else if (! frstln) { frstln = TRUE_; } /* if (ntindex(line,'/').gt.0 .and. index(line,'//').eq.0) then */ if (ntindex_(line, "/", (ftnlen)128, (ftnlen)1) > 0 && ntindex_(line, "//", (ftnlen)128, (ftnlen)2) == 0) { iv = iv % all_1.nvnow + 1; iinst = all_1.instnum[iv - 1]; } goto L4; L999: cl__1.cerr = 0; cl__1.cunit = 10; cl__1.csta = 0; f_clos(&cl__1); /* In the mbrest checks, must run through ALL noinst files (not just noinow) */ i__1 = all_1.noinst; for (iinst = 1; iinst <= i__1; ++iinst) { /* c+++ */ /* c */ /* c Temporarily transfer entire scratch file to real file */ /* c */ /* rewind(10+iinst) */ /* open(40,file='s2pout'//char(48+iinst)//'.pmx') */ /* do 50 m = 1 , 10000 */ /* read(10+iinst,'(a)',end=51)line */ /* lenline = lenstr(line,128) */ /* if (lenline .ge. 1) then */ /* write(40,'(a)')line(1:lenline) */ /* else */ /* write(40,'(a)')' ' */ /* end if */ /* 50 continue */ /* 51 continue */ /* close(40) */ /* c+++ */ if (all_1.nvi[iinst - 1] == 1) { mbrests_(&iinst, jobname, &ljob, (ftnlen)27); } else { /* Send a signal with ljob to bypass most mbrest processing */ i__2 = -ljob; mbrests_(&iinst, jobname, &i__2, (ftnlen)27); } /* L11: */ } } /* MAIN__ */ integer lenstr_(string, n, string_len) char *string; integer *n; ftnlen string_len; { /* System generated locals */ integer ret_val; for (ret_val = *n; ret_val >= 1; --ret_val) { if (*(unsigned char *)&string[ret_val - 1] != ' ') { return ret_val; } /* L1: */ } ret_val = 0; return ret_val; } /* lenstr_ */ /* Subroutine */ int allparts_(string, n, string_len) char *string; integer *n; ftnlen string_len; { /* System generated locals */ integer i__1; /* Builtin functions */ /* Subroutine */ int s_copy(); integer s_wsfe(), do_fio(), e_wsfe(); /* Local variables */ static integer iinst; extern integer lenstr_(); static integer len; /* Fortran I/O blocks */ static cilist io___88 = { 0, 0, 0, "(a)", 0 }; len = lenstr_(string, n, string_len); if (len == 0) { len = 1; s_copy(string, " ", string_len, (ftnlen)1); } i__1 = all_1.noinow; for (iinst = 1; iinst <= i__1; ++iinst) { io___88.ciunit = all_1.iorig[iinst - 1] + 10; s_wsfe(&io___88); do_fio(&c__1, string, len); e_wsfe(); /* L1: */ } return 0; } /* allparts_ */ /* Subroutine */ int mbrests_(iv, jobname, ljob, jobname_len) integer *iv; char *jobname; integer *ljob; ftnlen jobname_len; { /* System generated locals */ address a__1[2], a__2[3]; integer i__1[2], i__2[3], i__3, i__4; real r__1; char ch__1[1], ch__2[18], ch__3[4], ch__4[2], ch__5[10]; cilist ci__1; icilist ici__1; olist o__1; cllist cl__1; alist al__1; /* Builtin functions */ integer f_rew(); /* Subroutine */ int s_cat(); integer f_open(), s_rsfe(), do_fio(), e_rsfe(), s_cmp(), s_wsfe(), e_wsfe( ), s_wsle(), do_lio(), e_wsle(); /* Subroutine */ int s_stop(); integer i_indx(), s_rsfi(), e_rsfi(); /* Subroutine */ int s_copy(); double r_lg10(); integer f_clos(); /* Local variables */ static integer ndig; static char line[128*50]; static integer idxb, nmbr, idxs, lsym; static char line1[128]; static logical type4; static integer i__, icden, iline, lpart; static char partq[2]; static integer lwbrs, nwbrs, il, iw, lenbar; static char sq[1]; static integer ipenew, mtrden; static logical wbrest; extern integer lenstr_(); static integer ip1; static logical newmtr; static integer lwbrsx, mtrnum; static char wbrsym[3*2]; static integer ipc, ipe, len, idx, lenbeat; static logical alldone; static char sym[80]; extern integer ifnodur_(), ntindex_(); static integer lenmult; extern /* Subroutine */ int dosetup_(); static logical rpfirst; extern /* Subroutine */ int fwbrsym_(), nextsym_(); /* Fortran I/O blocks */ static cilist io___95 = { 0, 0, 0, "(a)", 0 }; static cilist io___98 = { 0, 30, 0, "(a)", 0 }; static cilist io___99 = { 0, 30, 0, "(a)", 0 }; static cilist io___100 = { 0, 6, 0, 0, 0 }; static cilist io___103 = { 0, 0, 1, "(a)", 0 }; static cilist io___104 = { 0, 30, 0, "(a)", 0 }; static cilist io___105 = { 0, 0, 0, "(a)", 0 }; static cilist io___106 = { 0, 30, 0, "(a)", 0 }; static cilist io___126 = { 0, 0, 1, "(a)", 0 }; static cilist io___127 = { 0, 30, 0, "(a)", 0 }; static cilist io___128 = { 0, 30, 0, "(a)", 0 }; static cilist io___129 = { 0, 6, 0, 0, 0 }; static cilist io___134 = { 0, 30, 0, "(a)", 0 }; static cilist io___136 = { 0, 6, 0, 0, 0 }; static cilist io___138 = { 0, 30, 0, "(a)", 0 }; static cilist io___140 = { 0, 30, 0, "(a)", 0 }; static cilist io___141 = { 0, 30, 0, "(a)", 0 }; static cilist io___142 = { 0, 30, 0, "(a)", 0 }; static cilist io___143 = { 0, 30, 0, "(a)", 0 }; type4 = FALSE_; *(unsigned char *)sq = '\\'; alldone = FALSE_; al__1.aerr = 0; al__1.aunit = *iv + 10; f_rew(&al__1); /* open(20,file=jobname(1:abs(ljob))//char(48+iv)//'.pmx') */ if (*iv < 10) { *(unsigned char *)partq = (char) (*iv + 48); lpart = 1; } else { /* Writing concatenation */ i__1[0] = 1, a__1[0] = "1"; *(unsigned char *)&ch__1[0] = *iv + 38; i__1[1] = 1, a__1[1] = ch__1; s_cat(partq, a__1, i__1, &c__2, (ftnlen)2); lpart = 2; } o__1.oerr = 0; o__1.ounit = 30; o__1.ofnmlen = abs(*ljob) + lpart + 4; /* Writing concatenation */ i__2[0] = abs(*ljob), a__2[0] = jobname; i__2[1] = lpart, a__2[1] = partq; i__2[2] = 4, a__2[2] = ".pmx"; s_cat(ch__2, a__2, i__2, &c__3, (ftnlen)18); o__1.ofnm = ch__2; o__1.orl = 0; o__1.osta = 0; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; f_open(&o__1); for (i__ = 1; i__ <= 10000; ++i__) { io___95.ciunit = *iv + 10; s_rsfe(&io___95); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); if (*(unsigned char *)&line[0] == '%' || s_cmp(line, "---", (ftnlen)3, (ftnlen)3) == 0 || type4) { len = lenstr_(line, &c__128, (ftnlen)128); if (len > 0) { s_wsfe(&io___98); do_fio(&c__1, line, len); e_wsfe(); } else { s_wsfe(&io___99); do_fio(&c__1, " ", (ftnlen)1); e_wsfe(); } if (s_cmp(line, "---", (ftnlen)3, (ftnlen)3) == 0) { type4 = ! type4; } } else { goto L11; } /* L10: */ } s_wsle(&io___100); do_lio(&c__9, &c__1, "You should not be here in scor2prt. Call Dr. Don", (ftnlen)49); e_wsle(); s_stop("", (ftnlen)0); L11: /* Finished reading opening type4 TeX and comments. Next line to be read */ /* will contain the first of the input numbers */ dosetup_(iv, line, &mtrnum, &mtrden, (ftnlen)128); for (i__ = 1; i__ <= 10000; ++i__) { L13: io___103.ciunit = *iv + 10; i__3 = s_rsfe(&io___103); if (i__3 != 0) { goto L999; } i__3 = do_fio(&c__1, line, (ftnlen)128); if (i__3 != 0) { goto L999; } i__3 = e_rsfe(); if (i__3 != 0) { goto L999; } L7: len = lenstr_(line, &c__128, (ftnlen)128); /* Pass-through if instrumnet has >1 voice. */ if (*ljob < 0) { goto L2; } if (i_indx("TtTiTch+h-h l ", line, (ftnlen)14, (ftnlen)2) > 0) { /* Traps titles, instruments, composers, headers, lower strings. Read 2 lines. */ s_wsfe(&io___104); do_fio(&c__1, line, len); e_wsfe(); io___105.ciunit = *iv + 10; s_rsfe(&io___105); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); len = lenstr_(line, &c__128, (ftnlen)128); goto L2; } if (i__ == 1 || i__ > 5 && *(unsigned char *)&line[0] == 'm') { /* NOTE! The above test is truly bogus. */ if (*(unsigned char *)&line[0] == '%') { s_wsfe(&io___106); do_fio(&c__1, line, len); e_wsfe(); goto L13; } if (i__ == 1) { /* read(line(1),'(10x,2i5)')mtrnum,mtrden */ } else { /* Check for slashes (new meter change syntax) */ idxs = i_indx(line, "/", (ftnlen)128, (ftnlen)1); idxb = i_indx(line, " ", (ftnlen)128, (ftnlen)1); newmtr = idxs > 0 && (idxb == 0 || idxs < idxb); if (! newmtr) { /* Old way, no slashes, uses 'o' for lonesome '1' */ icden = 3; if (*(unsigned char *)&line[1] == 'o') { mtrnum = 1; } else { mtrnum = *(unsigned char *)&line[1] - 48; if (mtrnum == 1) { icden = 4; mtrnum = *(unsigned char *)&line[2] - 38; } } mtrden = *(unsigned char *)&line[icden - 1] - 48; } else { /* New way with slashes: idxs is index of 1st slash! */ ici__1.icierr = 0; ici__1.iciend = 0; ici__1.icirnum = 1; ici__1.icirlen = idxs - 2; ici__1.iciunit = line + 1; /* Writing concatenation */ i__2[0] = 2, a__2[0] = "(i"; *(unsigned char *)&ch__1[0] = idxs + 46; i__2[1] = 1, a__2[1] = ch__1; i__2[2] = 1, a__2[2] = ")"; ici__1.icifmt = (s_cat(ch__3, a__2, i__2, &c__3, (ftnlen) 4), ch__3); s_rsfi(&ici__1); do_fio(&c__1, (char *)&mtrnum, (ftnlen)sizeof(integer)); e_rsfi(); i__3 = idxs; idxb = i_indx(line + i__3, "/", 128 - i__3, (ftnlen)1); i__3 = idxs; ici__1.icierr = 0; ici__1.iciend = 0; ici__1.icirnum = 1; ici__1.icirlen = idxs + idxb - 1 - i__3; ici__1.iciunit = line + i__3; /* Writing concatenation */ i__2[0] = 2, a__2[0] = "(i"; *(unsigned char *)&ch__1[0] = idxb + 47; i__2[1] = 1, a__2[1] = ch__1; i__2[2] = 1, a__2[2] = ")"; ici__1.icifmt = (s_cat(ch__3, a__2, i__2, &c__3, (ftnlen) 4), ch__3); s_rsfi(&ici__1); do_fio(&c__1, (char *)&mtrden, (ftnlen)sizeof(integer)); e_rsfi(); } } lenbeat = ifnodur_(&mtrden, "x", (ftnlen)1); lenmult = 1; if (mtrden == 2) { lenbeat = 16; lenmult = 2; } lenbar = lenmult * mtrnum * lenbeat; fwbrsym_(&lenbar, &nwbrs, wbrsym, &lwbrs, (ftnlen)3); } ip1 = 0; s_copy(line1, line, (ftnlen)128, (ftnlen)128); i__3 = nwbrs; for (iw = 0; iw <= i__3; ++iw) { if (iw > 0) { idx = ntindex_(line1, wbrsym + (iw - 1) * 3, (ftnlen)128, lwbrs); if (idx > 0) { /* Check for blank or shifted rest, discount it if it's there */ i__4 = idx + lwbrs - 1; if (s_cmp(line1 + i__4, " ", idx + lwbrs - i__4, (ftnlen) 1) != 0) { idx = 0; } } } else { idx = ntindex_(line1, "rp", (ftnlen)128, (ftnlen)2); /* Check for raised rest */ if (idx > 0) { i__4 = idx + 1; if (s_cmp(line1 + i__4, " ", idx + 2 - i__4, (ftnlen)1) != 0) { idx = 0; } } } if (idx > 0) { if (ip1 == 0) { ip1 = idx; } else { ip1 = min(ip1,idx); } } /* L3: */ } /* Writing concatenation */ i__1[0] = 1, a__1[0] = sq; i__1[1] = 1, a__1[1] = sq; s_cat(ch__4, a__1, i__1, &c__2, (ftnlen)2); if (i__ < 5 || *(unsigned char *)&line[0] == '%' || s_cmp(line, ch__4, (ftnlen)2, (ftnlen)2) == 0 || ip1 == 0) { goto L2; } /* Switch to multibar rest search mode!!! Start forward in line(1) */ rpfirst = s_cmp(line1 + (ip1 - 1), "rp", (ftnlen)2, (ftnlen)2) == 0; iline = 1; nmbr = 1; if (rpfirst) { lwbrsx = 2; } else { lwbrsx = lwbrs; } ipe = ip1 + lwbrsx - 1; L4: if (ipe == len) { /* Need a new line */ ++iline; L6: io___126.ciunit = *iv + 10; i__3 = s_rsfe(&io___126); if (i__3 != 0) { goto L998; } i__3 = do_fio(&c__1, line + (iline - 1 << 7), (ftnlen)128); if (i__3 != 0) { goto L998; } i__3 = e_rsfe(); if (i__3 != 0) { goto L998; } len = lenstr_(line + (iline - 1 << 7), &c__128, (ftnlen)128); if (*(unsigned char *)&line[(iline - 1) * 128] == '%') { s_wsfe(&io___127); do_fio(&c__1, "% Following comment has been moved forward", ( ftnlen)42); e_wsfe(); s_wsfe(&io___128); do_fio(&c__1, line + (iline - 1 << 7), len); e_wsfe(); goto L6; } ipe = 0; goto L4; L998: /* No more input left */ s_wsle(&io___129); do_lio(&c__9, &c__1, "All done!", (ftnlen)9); e_wsle(); alldone = TRUE_; ipe = 0; --iline; len = lenstr_(line + (iline - 1 << 7), &c__128, (ftnlen)128); goto L4; } else { if (alldone) { *(unsigned char *)sym = ' '; } else { /* ipe 0) { ipe = ipenew; goto L4; } else { wbrest = FALSE_; if (alldone) { goto L12; } i__3 = nwbrs; for (iw = 1; iw <= i__3; ++iw) { wbrest = wbrest || s_cmp(sym, wbrsym + (iw - 1) * 3, lsym, lwbrs) == 0; /* L5: */ } wbrest = wbrest || s_cmp(sym, "r", lsym, (ftnlen)1) == 0 && lwbrs == 2 || s_cmp(sym, "rd", lsym, (ftnlen)2) == 0 && lwbrs == 3 || s_cmp(sym, "rp", lsym, (ftnlen)2) == 0 || s_cmp(sym, "r", lsym, (ftnlen)1) == 0 && rpfirst; L12: if (wbrest) { ipe = ipenew; ++nmbr; goto L4; } else { /* AHA! Failed prev. test, so last symbol was *not* mbr. */ /* It must be saved, and its starting position is ipenew-lsym+1 */ if (nmbr > 1) { /* Write stuff up to start of mbr */ if (ip1 > 1) { s_wsfe(&io___134); do_fio(&c__1, line, ip1 - 1); e_wsfe(); } /* Insert mbr symbol. Always end with a slash just in case next sym must be */ /* at start of block. May think this causes undefined octaves, but */ /* probably not since it's a single voice. */ r__1 = nmbr + (float).01; ndig = (integer) r_lg10(&r__1) + 1; s_wsle(&io___136); do_lio(&c__9, &c__1, "Inserting rm, iv,nmbr:", ( ftnlen)22); do_lio(&c__3, &c__1, (char *)&(*iv), (ftnlen)sizeof( integer)); do_lio(&c__3, &c__1, (char *)&nmbr, (ftnlen)sizeof( integer)); e_wsle(); ci__1.cierr = 0; ci__1.ciunit = 30; /* Writing concatenation */ i__2[0] = 5, a__2[0] = "(a2,i"; *(unsigned char *)&ch__1[0] = ndig + 48; i__2[1] = 1, a__2[1] = ch__1; i__2[2] = 4, a__2[2] = ",a2)"; ci__1.cifmt = (s_cat(ch__5, a__2, i__2, &c__3, ( ftnlen)10), ch__5); s_wsfe(&ci__1); do_fio(&c__1, "rm", (ftnlen)2); do_fio(&c__1, (char *)&nmbr, (ftnlen)sizeof(integer)); do_fio(&c__1, " /", (ftnlen)2); e_wsfe(); if (alldone) { goto L999; } ipc = ipenew - lsym + 1; s_copy(line, line + ((iline - 1 << 7) + (ipc - 1)), ( ftnlen)128, len - (ipc - 1)); } else { /* Write old stuff up to end of original lonesome wbr, save the rest. */ /* 4 cases: (wbr /) , (wbr line-end) , (wbr followed by other non-/ symbols) , */ /* alldone. */ /* In 1st 2 will have gotten some other lines, so write all up to one b4 last */ /* non-comment line; then revert to normal mode on that. In 3rd case must */ /* split line. */ if (alldone) { s_wsfe(&io___138); do_fio(&c__1, line, len); e_wsfe(); goto L999; } else if (iline > 1) { i__3 = iline - 1; for (il = 1; il <= i__3; ++il) { len = lenstr_(line + (il - 1 << 7), &c__128, ( ftnlen)128); s_wsfe(&io___140); do_fio(&c__1, line + (il - 1 << 7), len); e_wsfe(); /* L9: */ } s_copy(line, line + (iline - 1 << 7), (ftnlen)128, (ftnlen)128); } else { /* Since iline = 1 the wbr is not the last sym, so must split */ s_wsfe(&io___141); do_fio(&c__1, line, ip1 + lwbrsx - 1); e_wsfe(); i__3 = ip1 + lwbrsx; s_copy(line, line + i__3, (ftnlen)128, len - i__3) ; } } /* Exit multibar mode */ goto L7; } } } L2: if (len > 0) { s_wsfe(&io___142); do_fio(&c__1, line, len); e_wsfe(); } else { s_wsfe(&io___143); do_fio(&c__1, " ", (ftnlen)1); e_wsfe(); } /* L1: */ } L999: cl__1.cerr = 0; cl__1.cunit = *iv + 10; cl__1.csta = 0; f_clos(&cl__1); cl__1.cerr = 0; cl__1.cunit = 30; cl__1.csta = 0; f_clos(&cl__1); return 0; } /* mbrests_ */ integer ifnodur_(idur, dotq, dotq_len) integer *idur; char *dotq; ftnlen dotq_len; { /* System generated locals */ integer ret_val; /* Builtin functions */ integer s_wsle(), do_lio(), e_wsle(); /* Subroutine */ int s_stop(); /* Fortran I/O blocks */ static cilist io___144 = { 0, 6, 0, 0, 0 }; if (*idur == 6) { ret_val = 1; } else if (*idur == 3) { ret_val = 2; } else if (*idur == 1 || *idur == 16) { ret_val = 4; } else if (*idur == 8) { ret_val = 8; } else if (*idur == 4) { ret_val = 16; } else if (*idur == 2) { ret_val = 32; } else if (*idur == 0) { ret_val = 64; } else { s_wsle(&io___144); do_lio(&c__9, &c__1, "You entered an invalid note-length value", ( ftnlen)40); e_wsle(); s_stop("", (ftnlen)0); } if (*(unsigned char *)dotq == 'd') { ret_val = ret_val * 3 / 2; } return ret_val; } /* ifnodur_ */ /* Subroutine */ int fwbrsym_(lenbar, nwbrs, wbrsym, lwbrs, wbrsym_len) integer *lenbar, *nwbrs; char *wbrsym; integer *lwbrs; ftnlen wbrsym_len; { /* Builtin functions */ /* Subroutine */ int s_copy(); integer s_wsfe(), do_fio(), e_wsfe(); /* Fortran I/O blocks */ static cilist io___145 = { 0, 6, 0, "(33H Any whole-bar rests of duratio\ n ,i3, 26H/64 will not be recognized)", 0 }; /* Parameter adjustments */ wbrsym -= 3; /* Function Body */ *nwbrs = 1; *lwbrs = 2; if (*lenbar == 16) { s_copy(wbrsym + 3, "r4", (ftnlen)3, (ftnlen)2); } else if (*lenbar == 32) { s_copy(wbrsym + 3, "r2", (ftnlen)3, (ftnlen)2); } else if (*lenbar == 64) { s_copy(wbrsym + 3, "r0", (ftnlen)3, (ftnlen)2); } else if (*lenbar == 8) { s_copy(wbrsym + 3, "r8", (ftnlen)3, (ftnlen)2); } else if (*lenbar == 128) { s_copy(wbrsym + 3, "r9", (ftnlen)3, (ftnlen)2); } else { *nwbrs = 2; *lwbrs = 3; if (*lenbar == 24) { s_copy(wbrsym + 3, "rd4", (ftnlen)3, (ftnlen)3); s_copy(wbrsym + 6, "r4d", (ftnlen)3, (ftnlen)3); } else if (*lenbar == 48) { s_copy(wbrsym + 3, "rd2", (ftnlen)3, (ftnlen)3); s_copy(wbrsym + 6, "r2d", (ftnlen)3, (ftnlen)3); } else if (*lenbar == 96) { s_copy(wbrsym + 3, "rd0", (ftnlen)3, (ftnlen)3); s_copy(wbrsym + 6, "r0d", (ftnlen)3, (ftnlen)3); } else { s_wsfe(&io___145); do_fio(&c__1, (char *)&(*lenbar), (ftnlen)sizeof(integer)); e_wsfe(); } } return 0; } /* fwbrsym_ */ /* Subroutine */ int nextsym_(line, len, ipeold, ipenew, sym, lsym, line_len, sym_len) char *line; integer *len, *ipeold, *ipenew; char *sym; integer *lsym; ftnlen line_len; ftnlen sym_len; { /* System generated locals */ integer i__1, i__2; /* Builtin functions */ integer s_wsle(), do_lio(), e_wsle(); /* Subroutine */ int s_stop(), s_copy(); /* Local variables */ static integer ip, iip; /* Fortran I/O blocks */ static cilist io___146 = { 0, 6, 0, 0, 0 }; static cilist io___147 = { 0, 6, 0, 0, 0 }; static cilist io___150 = { 0, 6, 0, 0, 0 }; /* Know its the last symbol if on return ipenew = len!. So should never */ /* be called when ipstart=len. */ if (*ipeold >= *len) { s_wsle(&io___146); do_lio(&c__9, &c__1, "Called nextsym with ipstart>=len ", (ftnlen)33); e_wsle(); s_wsle(&io___147); do_lio(&c__9, &c__1, "Send files to Dr. Don at dsimons@logicon.com", ( ftnlen)44); e_wsle(); s_stop("", (ftnlen)0); } i__1 = *len; for (ip = *ipeold + 1; ip <= i__1; ++ip) { if (*(unsigned char *)&line[ip - 1] != ' ') { /* symbol starts here (ip). We're committed to exit the loop. */ if (ip < *len) { i__2 = *len; for (iip = ip + 1; iip <= i__2; ++iip) { if (*(unsigned char *)&line[iip - 1] != ' ') { goto L2; } /* iip is the space after the symbol */ *ipenew = iip - 1; *lsym = *ipenew - ip + 1; s_copy(sym, line + (ip - 1), (ftnlen)80, *ipenew - (ip - 1)); return 0; L2: ; } /* Have len>=2 and ends on len */ *ipenew = *len; *lsym = *ipenew - ip + 1; s_copy(sym, line + (ip - 1), (ftnlen)80, *ipenew - (ip - 1)); return 0; } else { /* ip = len */ *ipenew = *len; *lsym = 1; s_copy(sym, line + (ip - 1), (ftnlen)80, (ftnlen)1); return 0; } } /* L1: */ } s_wsle(&io___150); do_lio(&c__9, &c__1, "Error #3. Send files to Dr. Don at dsimons@logico\ n.com", (ftnlen)55); e_wsle(); } /* nextsym_ */ integer ntindex_(line, s2q, line_len, s2q_len) char *line, *s2q; ftnlen line_len; ftnlen s2q_len; { /* System generated locals */ integer ret_val, i__1, i__2; /* Builtin functions */ integer i_indx(), s_cmp(); /* Local variables */ static integer ndxs2, ndxbs; static logical intex; static integer ic; extern integer lenstr_(); static integer len; /* Returns index(line,s2q) if NOT in TeX string, 0 otherwise */ /* print*,'Starting ntindex. s2q:',s2q,', line(1:79) is below' */ /* print*,line(1:79) */ ndxs2 = i_indx(line, s2q, (ftnlen)128, s2q_len); ndxbs = i_indx(line, "\\", (ftnlen)128, (ftnlen)1); if (ndxbs == 0 || ndxs2 < ndxbs) { ret_val = ndxs2; /* print*,'No bs, or char is left of 1st bs, ntindex:',ntindex */ } else { /* There are both bs and s2q, and bs is to the left of sq2. So check bs's to */ /* right of first: End is '\ ', start is ' \' */ len = lenstr_(line, &c__128, (ftnlen)128); intex = TRUE_; /* print*,'intex+>',intex */ i__1 = len; for (ic = ndxbs + 1; ic <= i__1; ++ic) { if (ic == ndxs2) { if (intex) { ret_val = 0; i__2 = ic; ndxs2 = i_indx(line + i__2, s2q, len - i__2, s2q_len) + ic; /* print*,'ndxs2 =>',ndxs2 */ } else { ret_val = ndxs2; return ret_val; } /* print*,'Internal exit, intex, ntindex:',intex,ntindex */ } else /* if(complicated condition) */ { i__2 = ic; if (intex && s_cmp(line + i__2, "\\ ", ic + 2 - i__2, (ftnlen) 2) == 0) { intex = FALSE_; /* print*,'intex+>',intex */ } else /* if(complicated condition) */ { i__2 = ic; if (! intex && s_cmp(line + i__2, " \\", ic + 2 - i__2, ( ftnlen)2) == 0) { intex = TRUE_; /* print*,'intex+>',intex */ } } } /* L1: */ } /* print*,'Out end of loop 1' */ } /* print*,'Exiting ntindex at the end???' */ return ret_val; } /* ntindex_ */ /* Subroutine */ int getchar_(line, iccount, charq, line_len, charq_len) char *line; integer *iccount; char *charq; ftnlen line_len; ftnlen charq_len; { /* Builtin functions */ integer s_rsfe(), do_fio(), e_rsfe(); /* Fortran I/O blocks */ static cilist io___156 = { 0, 10, 0, "(a)", 0 }; /* Gets the next character out of line*128. If pointer iccount=128 on entry, */ /* then reads in a new line. Resets iccount to position of the new character. */ if (*iccount == 128) { s_rsfe(&io___156); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); *iccount = 0; } ++(*iccount); *(unsigned char *)charq = *(unsigned char *)&line[*iccount - 1]; return 0; } /* getchar_ */ doublereal readin_(line, iccount, iread, line_len) char *line; integer *iccount, *iread; ftnlen line_len; { /* System generated locals */ address a__1[3]; integer i__1[3], i__2; real ret_val; char ch__1[27], ch__2[6], ch__3[1]; icilist ici__1; /* Builtin functions */ integer s_rsfe(), do_fio(), e_rsfe(), i_indx(), s_wsle(); /* Subroutine */ int s_cat(); integer do_lio(), e_wsle(); /* Subroutine */ int s_stop(); integer s_rsfi(), e_rsfi(); /* Local variables */ static char durq[1]; extern /* Subroutine */ int allparts_(); static integer i1, i2; extern /* Subroutine */ int chkcom_(); static integer icf; extern /* Subroutine */ int getchar_(); /* Fortran I/O blocks */ static cilist io___157 = { 0, 10, 0, "(a)", 0 }; static cilist io___161 = { 0, 6, 0, 0, 0 }; static cilist io___163 = { 0, 6, 0, 0, 0 }; /* Reads a piece of setup data from line, gets a new line from */ /* file 10 (jobname.pmx) if needed, Transfers comment lines into all parts. */ /* iread controls copying of values into scratch files for parts, but only */ /* if not replacing. */ /* iread input value written */ /* -1 nvi nothing (only used when noinst<0 initially) */ /* 0 various value read */ /* 1 nv -1 , replace later with nvi(i) */ /* 2 noinst 1 */ /* 3 np -2 , replace later with (nsyst-1)/12+1 */ /* 4 musicsize 20 */ /* 5 fracondent 0.05 */ L4: if (*iccount == 128) { s_rsfe(&io___157); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); if (all_1.replacing) { all_1.replacing = FALSE_; } chkcom_(line, (ftnlen)128); *iccount = 0; } ++(*iccount); /* Find next non-blank or end of line */ for (*iccount = *iccount; *iccount <= 127; ++(*iccount)) { if (*(unsigned char *)&line[*iccount - 1] != ' ') { goto L3; } /* L2: */ } /* If here, need to get a new line */ *iccount = 128; goto L4; L3: /* iccount now points to start of number to read */ i1 = *iccount; L5: getchar_(line, iccount, durq, (ftnlen)128, (ftnlen)1); /* Remember that getchar first increments iccount, *then* reads a character. */ if (i_indx("0123456789.-", durq, (ftnlen)12, (ftnlen)1) > 0) { goto L5; } i2 = *iccount - 1; if (i2 < i1) { s_wsle(&io___161); /* Writing concatenation */ i__1[0] = 7, a__1[0] = "Found \""; i__1[1] = 1, a__1[1] = durq; i__1[2] = 19, a__1[2] = "\" instead of number"; s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)27); do_lio(&c__9, &c__1, ch__1, (ftnlen)27); e_wsle(); s_stop("1", (ftnlen)1); } icf = i2 - i1 + 49; ici__1.icierr = 0; ici__1.iciend = 0; ici__1.icirnum = 1; ici__1.icirlen = i2 - (i1 - 1); ici__1.iciunit = line + (i1 - 1); /* Writing concatenation */ i__1[0] = 2, a__1[0] = "(f"; *(unsigned char *)&ch__3[0] = icf; i__1[1] = 1, a__1[1] = ch__3; i__1[2] = 3, a__1[2] = ".0)"; ici__1.icifmt = (s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)6), ch__2); s_rsfi(&ici__1); do_fio(&c__1, (char *)&ret_val, (ftnlen)sizeof(real)); e_rsfi(); if (! all_1.replacing) { if (*iread == 0) { i__2 = i2 - i1 + 1; allparts_(line + (i1 - 1), &i__2, i2 - (i1 - 1)); } else if (*iread == 1) { allparts_("-999", &c__4, (ftnlen)4); } else if (*iread == 2) { allparts_("1", &c__1, (ftnlen)1); } else if (*iread == 3) { allparts_("-998", &c__4, (ftnlen)4); } else if (*iread == 4) { allparts_("20", &c__2, (ftnlen)2); } else if (*iread == 5) { allparts_(".05", &c__3, (ftnlen)3); } else if (*iread != -1) { s_wsle(&io___163); do_lio(&c__9, &c__1, "Error with iread in readin", (ftnlen)26); e_wsle(); s_stop("", (ftnlen)0); } } return ret_val; } /* readin_ */ /* Subroutine */ int chkcom_(line, line_len) char *line; ftnlen line_len; { /* System generated locals */ integer i__1, i__2; /* Builtin functions */ integer s_rsfe(), do_fio(), e_rsfe(), i_indx(), s_cmp(), s_wsfe(), e_wsfe( ); /* Local variables */ static integer idxb; static logical clefpend; static integer idxl, idxm, idxn; extern /* Subroutine */ int allparts_(); static integer j, k; extern /* Subroutine */ int zapbl_(); static integer iposc0; extern integer lenstr_(); static integer ivq, lenline; /* Fortran I/O blocks */ static cilist io___164 = { 0, 10, 0, "(a)", 0 }; static cilist io___173 = { 0, 10, 0, "(a)", 0 }; static cilist io___176 = { 0, 0, 0, "(a)", 0 }; static cilist io___177 = { 0, 0, 0, "(a)", 0 }; static cilist io___178 = { 0, 10, 1, "(a)", 0 }; /* Assume that line has just been read. No need to change iccount since we only */ /* process full lines. */ L1: if (*(unsigned char *)line != '%') { return 0; } /* If here, line has some sort of comment */ if (*(unsigned char *)&line[1] == '%') { if (! all_1.insetup) { /* Suck up a line, then flow out of "if" block to get another and loop */ s_rsfe(&io___164); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); /* ++VV */ /* UNLESS (a) it has a score-only "M" and changes # of inst's. */ if (i_indx(line, "M", (ftnlen)128, (ftnlen)1) > 0) { idxl = i_indx(line, "L", (ftnlen)128, (ftnlen)1); idxm = i_indx(line, "M", (ftnlen)128, (ftnlen)1); idxn = i_indx(line, "n", (ftnlen)128, (ftnlen)1); idxb = i_indx(line, " ", (ftnlen)128, (ftnlen)1); if (idxl < idxm && idxm < idxn && (idxb == 0 || idxn < idxb)) { i__1 = idxn; all_1.noinow = *(unsigned char *)&line[i__1] - 48; clefpend = TRUE_; /* Next noinow digits are original inst. #'s of new inst. set. Next noinow */ /* char's after that are clefs */ all_1.nvnow = 0; i__1 = all_1.noinow; for (j = 1; j <= i__1; ++j) { i__2 = idxn + 1 + j - 1; all_1.iorig[j - 1] = *(unsigned char *)&line[i__2] - 48; iposc0 = idxn + 1 + all_1.noinow; i__2 = all_1.nvi[all_1.iorig[j - 1] - 1]; for (k = 1; k <= i__2; ++k) { ++all_1.nvnow; /* clefq(nvnow) = line(iposc0+nvnow:iposc0+nvnow) */ all_1.instnum[all_1.nvnow - 1] = j; all_1.botv[all_1.nvnow - 1] = k == 1 && j != 1; /* L25: */ } /* L24: */ } } } /* or if it's "h" or "l", need to suck up one more line */ if (*(unsigned char *)line == 'h' && i_indx("+- ", line + 1, ( ftnlen)3, (ftnlen)1) > 0 || s_cmp(line, "l ", (ftnlen)2, ( ftnlen)2) == 0) { s_rsfe(&io___173); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); } } else { /* In setup mode. Set flag, flow out and do use following line */ all_1.replacing = TRUE_; } } else if (*(unsigned char *)&line[1] == '!') { /* Copy to all parts */ allparts_(line + 2, &c__125, (ftnlen)126); } else { /* Get value of hex integer 1,2,...,9,a,b,c in 2nd position, zero otherwise */ ivq = i_indx("123456789abc", line + 1, (ftnlen)12, (ftnlen)1); /* Only treat as part-specific pmx line if number .le. noinst */ if (ivq < 1 || ivq > all_1.noinst) { /* Simple comment. */ allparts_(line, &c__128, (ftnlen)128); } else { /* Instrument comment, copy only to part */ lenline = lenstr_(line, &c__128, (ftnlen)128); if (lenline > 2) { io___176.ciunit = ivq + 10; s_wsfe(&io___176); do_fio(&c__1, line + 2, lenline - 2); e_wsfe(); } else { /* Transferring blank line */ io___177.ciunit = ivq + 10; s_wsfe(&io___177); do_fio(&c__1, " ", (ftnlen)1); e_wsfe(); } } } i__1 = s_rsfe(&io___178); if (i__1 != 0) { goto L2; } i__1 = do_fio(&c__1, line, (ftnlen)128); if (i__1 != 0) { goto L2; } i__1 = e_rsfe(); if (i__1 != 0) { goto L2; } zapbl_(line, &c__128, (ftnlen)128); goto L1; L2: return 0; } /* chkcom_ */ /* Subroutine */ int dosetup_(iv, line, mtrnum, mtrden, line_len) integer *iv; char *line; integer *mtrnum, *mtrden; ftnlen line_len; { /* System generated locals */ integer i__1, i__2; /* Builtin functions */ integer s_wsfe(), do_fio(), e_wsfe(), i_nint(); /* Local variables */ static integer iset; static real xdata; static integer ioi, noi, iccount; extern /* Subroutine */ int partnum_(); /* Fortran I/O blocks */ static cilist io___182 = { 0, 30, 0, "(i5)", 0 }; static cilist io___184 = { 0, 30, 0, "(i5)", 0 }; static cilist io___186 = { 0, 30, 0, "(i5)", 0 }; static cilist io___187 = { 0, 30, 0, "(i5)", 0 }; static cilist io___188 = { 0, 30, 0, "(i5)", 0 }; static cilist io___189 = { 0, 30, 0, "(i5)", 0 }; static cilist io___190 = { 0, 30, 0, "(f5.2)", 0 }; /* Transfers setup data from scratch file to real one for one instrument */ /* Data may be mixed with comments, but on entry 1st item is a number. */ /* Write a comment when encountered, as it comes. */ /* Write numbers one per line. */ /* Three input data require special handling: */ /* If not already replaced, i.e., if negative, then */ /* iset(1) (nv) will be replaced with nvi(i) */ /* iset(9) (npages) will be replaced with (nsyst-1)/12+1 */ /* iset(2), if negative, will be followed by extra numbers to be transf. */ iccount = 0; for (iset = 1; iset <= 12; ++iset) { partnum_(iv, &iccount, line, &xdata, (ftnlen)128); if (iset == 2) { if (xdata > (float)0.) { s_wsfe(&io___182); i__1 = (integer) (xdata + (float).1); do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); e_wsfe(); } else { noi = -xdata + (float).1; s_wsfe(&io___184); do_fio(&c__1, (char *)&noi, (ftnlen)sizeof(integer)); e_wsfe(); i__1 = noi; for (ioi = 1; ioi <= i__1; ++ioi) { partnum_(iv, &iccount, line, &xdata, (ftnlen)128); s_wsfe(&io___186); i__2 = (integer) (xdata + (float).1); do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer)); e_wsfe(); /* L2: */ } } } else if (iset != 8 && xdata < (float)0.) { /* Must be either nv or npages */ if ((integer) (-xdata + (float).1) == 999) { /* It's nv */ s_wsfe(&io___187); do_fio(&c__1, (char *)&all_2.nvi[*iv - 1], (ftnlen)sizeof( integer)); e_wsfe(); } else { /* npages must be computed */ s_wsfe(&io___188); i__1 = (all_2.nsyst - 1) / 12 + 1; do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); e_wsfe(); } } else if (iset != 7 && iset != 12) { /* write integer */ s_wsfe(&io___189); i__1 = i_nint(&xdata); do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer)); e_wsfe(); } else { /* write floating number */ s_wsfe(&io___190); do_fio(&c__1, (char *)&xdata, (ftnlen)sizeof(real)); e_wsfe(); } if (iset == 3) { *mtrnum = i_nint(&xdata); } else if (iset == 4) { *mtrden = i_nint(&xdata); } /* L1: */ } return 0; } /* dosetup_ */ /* Subroutine */ int partnum_(iv, iccount, line, xdata, line_len) integer *iv, *iccount; char *line; real *xdata; ftnlen line_len; { /* System generated locals */ address a__1[3]; integer i__1[3]; char ch__1[27], ch__2[6], ch__3[1]; icilist ici__1; /* Builtin functions */ integer s_rsfe(), do_fio(), e_rsfe(), s_wsfe(), e_wsfe(), i_indx(), s_wsle(); /* Subroutine */ int s_cat(); integer do_lio(), e_wsle(); /* Subroutine */ int s_stop(); integer s_rsfi(), e_rsfi(); /* Local variables */ static char durq[1]; static integer i1, i2; extern integer lenstr_(); static integer icf, len; extern /* Subroutine */ int getchar_(); /* Fortran I/O blocks */ static cilist io___191 = { 0, 0, 0, "(a)", 0 }; static cilist io___193 = { 0, 30, 0, "(a)", 0 }; static cilist io___197 = { 0, 6, 0, 0, 0 }; /* Simplified number parsing. Only looks for comment lines and numbers. */ L2: if (*iccount == 128) { io___191.ciunit = *iv + 10; s_rsfe(&io___191); do_fio(&c__1, line, (ftnlen)128); e_rsfe(); if (*(unsigned char *)line == '%') { len = lenstr_(line, &c__128, (ftnlen)128); s_wsfe(&io___193); do_fio(&c__1, line, len); e_wsfe(); goto L2; } *iccount = 0; } ++(*iccount); /* Find next non-blank or end of line */ for (*iccount = *iccount; *iccount <= 127; ++(*iccount)) { if (*(unsigned char *)&line[*iccount - 1] != ' ') { goto L3; } /* L4: */ } /* If here, iccount=128 and need to get a new line */ goto L2; L3: /* iccount now points to start of number to read */ i1 = *iccount; L5: getchar_(line, iccount, durq, (ftnlen)128, (ftnlen)1); /* Remember that getchar first increments iccount, *then* reads a character. */ if (i_indx("0123456789.-", durq, (ftnlen)12, (ftnlen)1) > 0) { goto L5; } i2 = *iccount - 1; if (i2 < i1) { s_wsle(&io___197); /* Writing concatenation */ i__1[0] = 7, a__1[0] = "Found \""; i__1[1] = 1, a__1[1] = durq; i__1[2] = 19, a__1[2] = "\" instead of number"; s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)27); do_lio(&c__9, &c__1, ch__1, (ftnlen)27); e_wsle(); s_stop("1", (ftnlen)1); } icf = i2 - i1 + 49; ici__1.icierr = 0; ici__1.iciend = 0; ici__1.icirnum = 1; ici__1.icirlen = i2 - (i1 - 1); ici__1.iciunit = line + (i1 - 1); /* Writing concatenation */ i__1[0] = 2, a__1[0] = "(f"; *(unsigned char *)&ch__3[0] = icf; i__1[1] = 1, a__1[1] = ch__3; i__1[2] = 3, a__1[2] = ".0)"; ici__1.icifmt = (s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)6), ch__2); s_rsfi(&ici__1); do_fio(&c__1, (char *)&(*xdata), (ftnlen)sizeof(real)); e_rsfi(); return 0; } /* partnum_ */ /* Subroutine */ int zapbl_(string, len, string_len) char *string; integer *len; ftnlen string_len; { /* System generated locals */ integer i__1; /* Builtin functions */ /* Subroutine */ int s_copy(); /* Local variables */ static integer i__; i__1 = *len; for (i__ = 1; i__ <= i__1; ++i__) { if (*(unsigned char *)&string[i__ - 1] == ' ') { goto L1; } if (i__ == 1) { return 0; } goto L2; L1: ; } /* If line is all blank, leave it alone */ return 0; L2: s_copy(string, string + (i__ - 1), string_len, *len - (i__ - 1)); return 0; } /* zapbl_ */